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,gUb2      !(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(4) :: gmuij,gmuij1,gmuij2,gmuji1,gmuji2
  91       real(kind=8),dimension(:),allocatable :: costab,sintab,&
  92        costab2,sintab2      !(maxres)
  93 ! This common block contains dipole-interaction matrices and their
  94 ! Cartesian derivatives.
  95 !      common /dipmat/
  96       real(kind=8),dimension(:,:,:,:),allocatable :: a_chuj      !(2,2,maxconts,maxres)
  97       real(kind=8),dimension(:,:,:,:,:,:),allocatable :: a_chuj_der      !(2,2,3,5,maxconts,maxres)
  98 !      common /diploc/
  99       real(kind=8),dimension(2,2,2) :: AEA,AEAderg,EAEA,AECA,&
 100        AECAderg,ADtEA,ADtEA1,AEAb1,AEAb1derg,AEAb2
 101       real(kind=8),dimension(2,2,2,2) :: EAEAderg,ADtEAderg,&
 102        ADtEA1derg,AEAb2derg
 103       real(kind=8),dimension(2,2,3,5,2,2) :: AEAderx,EAEAderx,&
 104        AECAderx,ADtEAderx,ADtEA1derx
 105       real(kind=8),dimension(2,3,5,2,2,2) :: AEAb1derx,AEAb2derx
 106       real(kind=8),dimension(3,2) :: g_contij
 107       real(kind=8) :: ekont
 108 ! 12/13/2008 (again Poland-Jaruzel war anniversary)
 109 !   RE: Parallelization of 4th and higher order loc-el correlations
 110 !      common /contdistrib/
 111       integer,dimension(:),allocatable :: ncont_sent,ncont_recv !(maxres)
 112 ! ncont_sent,ncont_recv są w multibody_ello i multibody_hb
 113 !-----------------------------------------------------------------------------
 114 ! commom.deriv;
 115 !      common /derivat/
 116 !      real(kind=8),dimension(:,:),allocatable :: dcdv,dxdv !(6,maxdim)
 117 !      real(kind=8),dimension(:,:),allocatable :: dxds !(6,maxres)
 118 !      real(kind=8),dimension(:,:,:),allocatable :: gradx,gradc !(3,maxres,2)
 119       real(kind=8),dimension(:,:),allocatable :: gvdwc,gelc,gelc_long,&
 120         gvdwpp,gvdwc_scpp,gradx_scp,gvdwc_scp,ghpbx,ghpbc,&
 121         gradcorr,gradcorr_long,gradcorr5_long,gradcorr6_long,&
 122         gcorr6_turn_long,gradxorr,gradcorr5,gradcorr6,gliptran,gliptranc,&
 123         gliptranx, &
 124         gshieldx,gshieldc,gshieldc_loc,gshieldx_ec,&
 125         gshieldc_ec,gshieldc_loc_ec,gshieldx_t3, &
 126         gshieldc_t3,gshieldc_loc_t3,gshieldx_t4,gshieldc_t4, &
 127         gshieldc_loc_t4,gshieldx_ll,gshieldc_ll,gshieldc_loc_ll,&
 128         grad_shield,gg_tube,gg_tube_sc,gradafm !(3,maxres)
 129 !-----------------------------NUCLEIC GRADIENT
 130       real(kind=8),dimension(:,:),allocatable  ::gradb_nucl,gradbx_nucl, &
 131         gvdwpsb1,gelpp,gvdwpsb,gelsbc,gelsbx,gvdwsbx,gvdwsbc,gsbloc,&
 132         gsblocx,gradcorr_nucl,gradxorr_nucl,gradcorr3_nucl,gradxorr3_nucl,&
 133         gvdwpp_nucl
 134 !-----------------------------NUCLEIC-PROTEIN GRADIENT
 135       real(kind=8),dimension(:,:),allocatable  :: gvdwx_scbase,gvdwc_scbase,&
 136          gvdwx_pepbase,gvdwc_pepbase,gvdwx_scpho,gvdwc_scpho,&
 137          gvdwc_peppho
 138 !------------------------------IONS GRADIENT
 139         real(kind=8),dimension(:,:),allocatable  ::  gradcatcat, &
 140           gradpepcat,gradpepcatx
 141 !      real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2)
 142
 143
 144       real(kind=8),dimension(:,:),allocatable :: gel_loc,gel_loc_long,&
 145         gcorr3_turn,gcorr4_turn,gcorr6_turn,gradb,gradbx !(3,maxres)
 146       real(kind=8),dimension(:),allocatable :: gel_loc_loc,&
 147         gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc,g_corr5_loc,&
 148         g_corr6_loc      !(maxvar)
 149       real(kind=8),dimension(:,:),allocatable :: gsccorc,gsccorx !(3,maxres)
 150       real(kind=8),dimension(:),allocatable :: gsccor_loc      !(maxres)
 151 !      real(kind=8),dimension(:,:,:),allocatable :: dtheta      !(3,2,maxres)
 152       real(kind=8),dimension(:,:),allocatable :: gscloc,gsclocx !(3,maxres)
 153 !      real(kind=8),dimension(:,:,:),allocatable :: dphi,dalpha,domega !(3,3,maxres)
 154       real(kind=8),dimension(:,:,:),allocatable :: grad_shield_side, &
 155          grad_shield_loc ! (3,maxcontsshileding,maxnres)
 156 !      integer :: nfl,icg
 157 !      common /deriv_loc/
 158       real(kind=8), dimension(:),allocatable :: fac_shield
 159       real(kind=8),dimension(3,5,2) :: derx,derx_turn
 160 !      common /deriv_scloc/
 161       real(kind=8),dimension(:,:),allocatable :: dXX_C1tab,dYY_C1tab,&
 162        dZZ_C1tab,dXX_Ctab,dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,&
 163        dZZ_XYZtab      !(3,maxres)
 164 !-----------------------------------------------------------------------------
 165 ! common.maxgrad
 166 !      common /maxgrad/
 167       real(kind=8) :: gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,&
 168        gradb_max,ghpbc_max,&
 169        gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
 170        gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
 171        gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
 172        gsccorx_max,gsclocx_max
 173 !-----------------------------------------------------------------------------
 174 ! common.MD
 175 !      common /back_constr/
 176       real(kind=8),dimension(:),allocatable :: dutheta,dugamma !(maxres)
 177       real(kind=8),dimension(:,:),allocatable :: duscdiff,duscdiffx !(3,maxres)
 178 !      common /qmeas/
 179       real(kind=8) :: Ucdfrag,Ucdpair
 180       real(kind=8),dimension(:,:),allocatable :: dUdconst,dUdxconst,&
 181        dqwol,dxqwol      !(3,0:MAXRES)
 182 !-----------------------------------------------------------------------------
 183 ! common.sbridge
 184 !      common /dyn_ssbond/
 185       real(kind=8),dimension(:,:),allocatable :: dyn_ssbond_ij !(maxres,maxres)
 186 !-----------------------------------------------------------------------------
 187 ! common.sccor
 188 ! Parameters of the SCCOR term
 189 !      common/sccor/
 190       real(kind=8),dimension(:,:,:,:),allocatable :: dcostau,dsintau,&
 191        dcosomicron,domicron      !(3,3,3,maxres2)
 192 !-----------------------------------------------------------------------------
 193 ! common.vectors
 194 !      common /vectors/
 195       real(kind=8),dimension(:,:),allocatable :: uy,uz !(3,maxres)
 196       real(kind=8),dimension(:,:,:,:),allocatable :: uygrad,uzgrad !(3,3,2,maxres)
 197 !-----------------------------------------------------------------------------
 198 ! common /przechowalnia/
 199       real(kind=8),dimension(:,:,:),allocatable :: zapas
 200       real(kind=8),dimension(:,:,:,:),allocatable ::zapas2 !(max_dim,maxconts,max_fg_procs)
 201       real(kind=8),dimension(:,:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
 202 !-----------------------------------------------------------------------------
 203 !-----------------------------------------------------------------------------
 204 !
 205 !
 206 !-----------------------------------------------------------------------------
 207       contains
 208 !-----------------------------------------------------------------------------
 209 ! energy_p_new_barrier.F
 210 !-----------------------------------------------------------------------------
 211       subroutine etotal(energia)
 212 !      implicit real*8 (a-h,o-z)
 213 !      include 'DIMENSIONS'
 214       use MD_data
 215 #ifndef ISNAN
 216       external proc_proc
 217 #ifdef WINPGI
 218 !MS$ATTRIBUTES C ::  proc_proc
 219 #endif
 220 #endif
 221 #ifdef MPI
 222       include "mpif.h"
 223 #endif
 224 !      include 'COMMON.SETUP'
 225 !      include 'COMMON.IOUNITS'
 226       real(kind=8),dimension(0:n_ene) :: energia
 227 !      include 'COMMON.LOCAL'
 228 !      include 'COMMON.FFIELD'
 229 !      include 'COMMON.DERIV'
 230 !      include 'COMMON.INTERACT'
 231 !      include 'COMMON.SBRIDGE'
 232 !      include 'COMMON.CHAIN'
 233 !      include 'COMMON.VAR'
 234 !      include 'COMMON.MD'
 235 !      include 'COMMON.CONTROL'
 236 !      include 'COMMON.TIME1'
 237       real(kind=8) :: time00
 238 !el local variables
 239       integer :: n_corr,n_corr1,ierror,imatupdate
 240       real(kind=8) :: etors,edihcnstr,etors_d,esccor,ehpb
 241       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,escloc,ees,eel_loc
 242       real(kind=8) :: eello_turn3,eello_turn4,estr,ebe,eliptran,etube, &
 243                       Eafmforce,ethetacnstr
 244       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
 245 ! now energies for nulceic alone parameters
 246       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 247                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 248                       ecorr3_nucl
 249 ! energies for ions
 250       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber
 251 ! energies for protein nucleic acid interaction
 252       real(kind=8) :: escbase,epepbase,escpho,epeppho
 253
 254 #ifdef MPI
 255       real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw
 256 ! shielding effect varibles for MPI
 257       real(kind=8) ::  fac_shieldbuf(nres), &
 258       grad_shield_locbuf1(3*maxcontsshi*nres), &
 259       grad_shield_sidebuf1(3*maxcontsshi*nres), &
 260       grad_shield_locbuf2(3*maxcontsshi*nres), &
 261       grad_shield_sidebuf2(3*maxcontsshi*nres), &
 262       grad_shieldbuf1(3*nres), &
 263       grad_shieldbuf2(3*nres)
 264
 265        integer ishield_listbuf(-1:nres), &
 266        shield_listbuf(maxcontsshi,-1:nres),k,j,i,iii,impishi,mojint,jjj
 267 !       print *,"I START ENERGY"
 268        imatupdate=100
 269 !       if (mod(itime_mat,imatupdate).eq.0) call make_SCSC_inter_list
 270 !      real(kind=8),  dimension(:),allocatable::  fac_shieldbuf
 271 !      real(kind=8), dimension(:,:,:),allocatable:: &
 272 !       grad_shield_locbuf,grad_shield_sidebuf
 273 !      real(kind=8), dimension(:,:),allocatable:: &
 274 !        grad_shieldbuf
 275 !       integer, dimension(:),allocatable:: &
 276 !       ishield_listbuf
 277 !       integer, dimension(:,:),allocatable::  shield_listbuf
 278 !       integer :: k,j,i
 279 !      if (.not.allocated(fac_shieldbuf)) then
 280 !          allocate(fac_shieldbuf(nres))
 281 !          allocate(grad_shield_locbuf(3,maxcontsshi,-1:nres))
 282 !          allocate(grad_shield_sidebuf(3,maxcontsshi,-1:nres))
 283 !          allocate(grad_shieldbuf(3,-1:nres))
 284 !          allocate(ishield_listbuf(nres))
 285 !          allocate(shield_listbuf(maxcontsshi,nres))
 286 !       endif
 287
 288 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 289 !     & " nfgtasks",nfgtasks
 290       if (nfgtasks.gt.1) then
 291         time00=MPI_Wtime()
 292 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 293         if (fg_rank.eq.0) then
 294           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 295 !          print *,"Processor",myrank," BROADCAST iorder"
 296 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 297 ! FG slaves as WEIGHTS array.
 298           weights_(1)=wsc
 299           weights_(2)=wscp
 300           weights_(3)=welec
 301           weights_(4)=wcorr
 302           weights_(5)=wcorr5
 303           weights_(6)=wcorr6
 304           weights_(7)=wel_loc
 305           weights_(8)=wturn3
 306           weights_(9)=wturn4
 307           weights_(10)=wturn6
 308           weights_(11)=wang
 309           weights_(12)=wscloc
 310           weights_(13)=wtor
 311           weights_(14)=wtor_d
 312           weights_(15)=wstrain
 313           weights_(16)=wvdwpp
 314           weights_(17)=wbond
 315           weights_(18)=scal14
 316           weights_(21)=wsccor
 317           weights_(26)=wvdwpp_nucl
 318           weights_(27)=welpp
 319           weights_(28)=wvdwpsb
 320           weights_(29)=welpsb
 321           weights_(30)=wvdwsb
 322           weights_(31)=welsb
 323           weights_(32)=wbond_nucl
 324           weights_(33)=wang_nucl
 325           weights_(34)=wsbloc
 326           weights_(35)=wtor_nucl
 327           weights_(36)=wtor_d_nucl
 328           weights_(37)=wcorr_nucl
 329           weights_(38)=wcorr3_nucl
 330           weights_(41)=wcatcat
 331           weights_(42)=wcatprot
 332           weights_(46)=wscbase
 333           weights_(47)=wpepbase
 334           weights_(48)=wscpho
 335           weights_(49)=wpeppho
 336 !          wcatcat= weights(41)
 337 !          wcatprot=weights(42)
 338
 339 ! FG Master broadcasts the WEIGHTS_ array
 340           call MPI_Bcast(weights_(1),n_ene,&
 341              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 342         else
 343 ! FG slaves receive the WEIGHTS array
 344           call MPI_Bcast(weights(1),n_ene,&
 345               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 346           wsc=weights(1)
 347           wscp=weights(2)
 348           welec=weights(3)
 349           wcorr=weights(4)
 350           wcorr5=weights(5)
 351           wcorr6=weights(6)
 352           wel_loc=weights(7)
 353           wturn3=weights(8)
 354           wturn4=weights(9)
 355           wturn6=weights(10)
 356           wang=weights(11)
 357           wscloc=weights(12)
 358           wtor=weights(13)
 359           wtor_d=weights(14)
 360           wstrain=weights(15)
 361           wvdwpp=weights(16)
 362           wbond=weights(17)
 363           scal14=weights(18)
 364           wsccor=weights(21)
 365           wvdwpp_nucl =weights(26)
 366           welpp  =weights(27)
 367           wvdwpsb=weights(28)
 368           welpsb =weights(29)
 369           wvdwsb =weights(30)
 370           welsb  =weights(31)
 371           wbond_nucl  =weights(32)
 372           wang_nucl   =weights(33)
 373           wsbloc =weights(34)
 374           wtor_nucl   =weights(35)
 375           wtor_d_nucl =weights(36)
 376           wcorr_nucl  =weights(37)
 377           wcorr3_nucl =weights(38)
 378           wcatcat= weights(41)
 379           wcatprot=weights(42)
 380           wscbase=weights(46)
 381           wpepbase=weights(47)
 382           wscpho=weights(48)
 383           wpeppho=weights(49)
 384 !      welpsb=weights(28)*fact(1)
 385 !
 386 !      wcorr_nucl= weights(37)*fact(1)
 387 !     wcorr3_nucl=weights(38)*fact(2)
 388 !     wtor_nucl=  weights(35)*fact(1)
 389 !     wtor_d_nucl=weights(36)*fact(2)
 390
 391         endif
 392         time_Bcast=time_Bcast+MPI_Wtime()-time00
 393         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 394 !        call chainbuild_cart
 395       endif
 396 !       print *,"itime_mat",itime_mat,imatupdate
 397         if (nfgtasks.gt.1) then
 398         call MPI_Bcast(itime_mat,1,MPI_INT,king,FG_COMM,IERROR)
 399         endif
 400        if (mod(itime_mat,imatupdate).eq.0) call make_SCp_inter_list
 401        write (iout,*) "after make_SCp_inter_list"
 402        if (mod(itime_mat,imatupdate).eq.0) call make_SCSC_inter_list
 403        write (iout,*) "after make_SCSC_inter_list"
 404
 405        if (mod(itime_mat,imatupdate).eq.0) call make_pp_inter_list
 406        write (iout,*) "after make_pp_inter_list"
 407
 408 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 409 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 410 #else
 411 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 412 !        call int_from_cart1(.false.)
 413 !      endif
 414 #endif
 415 #ifdef TIMING
 416       time00=MPI_Wtime()
 417 #endif
 418 !
 419 ! Compute the side-chain and electrostatic interaction energy
 420 !        print *, "Before EVDW"
 421 !      goto (101,102,103,104,105,106) ipot
 422       select case(ipot)
 423 ! Lennard-Jones potential.
 424 !  101 call elj(evdw)
 425        case (1)
 426          call elj(evdw)
 427 !d    print '(a)','Exit ELJcall el'
 428 !      goto 107
 429 ! Lennard-Jones-Kihara potential (shifted).
 430 !  102 call eljk(evdw)
 431        case (2)
 432          call eljk(evdw)
 433 !      goto 107
 434 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 435 !  103 call ebp(evdw)
 436        case (3)
 437          call ebp(evdw)
 438 !      goto 107
 439 ! Gay-Berne potential (shifted LJ, angular dependence).
 440 !  104 call egb(evdw)
 441        case (4)
 442 !       print *,"MOMO",scelemode
 443         if (scelemode.eq.0) then
 444          call egb(evdw)
 445         else
 446          call emomo(evdw)
 447         endif
 448 !      goto 107
 449 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 450 !  105 call egbv(evdw)
 451        case (5)
 452          call egbv(evdw)
 453 !      goto 107
 454 ! Soft-sphere potential
 455 !  106 call e_softsphere(evdw)
 456        case (6)
 457          call e_softsphere(evdw)
 458 !
 459 ! Calculate electrostatic (H-bonding) energy of the main chain.
 460 !
 461 !  107 continue
 462        case default
 463          write(iout,*)"Wrong ipot"
 464 !         return
 465 !   50 continue
 466       end select
 467 !      continue
 468 !        print *,"after EGB"
 469 ! shielding effect
 470        if (shield_mode.eq.2) then
 471                  call set_shield_fac2
 472
 473       if (nfgtasks.gt.1) then
 474       grad_shield_sidebuf1(:)=0.0d0
 475       grad_shield_locbuf1(:)=0.0d0
 476       grad_shield_sidebuf2(:)=0.0d0
 477       grad_shield_locbuf2(:)=0.0d0
 478       grad_shieldbuf1(:)=0.0d0
 479       grad_shieldbuf2(:)=0.0d0
 480 !#define DEBUG
 481 #ifdef DEBUG
 482        write(iout,*) "befor reduce fac_shield reduce"
 483        do i=1,nres
 484         write(2,*) "fac",itype(i,1),fac_shield(i),grad_shield(1,i)
 485         write(2,*) "list", shield_list(1,i),ishield_list(i), &
 486        grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 487        enddo
 488 #endif
 489         iii=0
 490         jjj=0
 491         do i=1,nres
 492         ishield_listbuf(i)=0
 493         do k=1,3
 494         iii=iii+1
 495         grad_shieldbuf1(iii)=grad_shield(k,i)
 496         enddo
 497         enddo
 498         do i=1,nres
 499          do j=1,maxcontsshi
 500           do k=1,3
 501               jjj=jjj+1
 502               grad_shield_sidebuf1(jjj)=grad_shield_side(k,j,i)
 503               grad_shield_locbuf1(jjj)=grad_shield_loc(k,j,i)
 504            enddo
 505           enddo
 506          enddo
 507         call MPI_Allgatherv(fac_shield(ivec_start), &
 508         ivec_count(fg_rank1), &
 509         MPI_DOUBLE_PRECISION,fac_shieldbuf(1),ivec_count(0), &
 510         ivec_displ(0), &
 511         MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 512         call MPI_Allgatherv(shield_list(1,ivec_start), &
 513         ivec_count(fg_rank1), &
 514         MPI_I50,shield_listbuf(1,1),ivec_count(0), &
 515         ivec_displ(0), &
 516         MPI_I50,FG_COMM,IERROR)
 517 !        write(2,*) "After I50"
 518 !        call flush(iout)
 519         call MPI_Allgatherv(ishield_list(ivec_start), &
 520         ivec_count(fg_rank1), &
 521         MPI_INTEGER,ishield_listbuf(1),ivec_count(0), &
 522         ivec_displ(0), &
 523         MPI_INTEGER,FG_COMM,IERROR)
 524 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 525
 526 !        write(2,*) ivec_count(fg_rank1)*3,ivec_count(0)*3,ivec_displ(0)*3,3*ivec_start-2
 527 !        write (2,*) "before"
 528 !        write(2,*) grad_shieldbuf1
 529 !        call MPI_Allgatherv(grad_shieldbuf1(3*ivec_start-2), &
 530 !        ivec_count(fg_rank1)*3, &
 531 !        MPI_DOUBLE_PRECISION,grad_shieldbuf2(1),ivec_count(0), &
 532 !        ivec_count(0), &
 533 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 534         call MPI_Allreduce(grad_shieldbuf1(1),grad_shieldbuf2(1), &
 535         nres*3, &
 536         MPI_DOUBLE_PRECISION, &
 537         MPI_SUM, &
 538         FG_COMM,IERROR)
 539         call MPI_Allreduce(grad_shield_sidebuf1(1),grad_shield_sidebuf2(1), &
 540         nres*3*maxcontsshi, &
 541         MPI_DOUBLE_PRECISION, &
 542         MPI_SUM, &
 543         FG_COMM,IERROR)
 544
 545         call MPI_Allreduce(grad_shield_locbuf1(1),grad_shield_locbuf2(1), &
 546         nres*3*maxcontsshi, &
 547         MPI_DOUBLE_PRECISION, &
 548         MPI_SUM, &
 549         FG_COMM,IERROR)
 550
 551 !        write(2,*) "after"
 552 !        write(2,*) grad_shieldbuf2
 553
 554 !        call MPI_Allgatherv(grad_shield_sidebuf1(3*maxcontsshi*ivec_start-2), &
 555 !        ivec_count(fg_rank1)*3*maxcontsshi, &
 556 !        MPI_DOUBLE_PRECISION,grad_shield_sidebuf2(1),ivec_count(0)*3*maxcontsshi,&
 557 !        ivec_displ(0)*3*maxcontsshi, &
 558 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 559 !        write(2,*) "After grad_shield_side"
 560 !        call flush(iout)
 561 !        call MPI_Allgatherv(grad_shield_locbuf1(3*maxcontsshi*ivec_start-2), &
 562 !        ivec_count(fg_rank1)*3*maxcontsshi, &
 563 !        MPI_DOUBLE_PRECISION,grad_shield_locbuf2(1),ivec_count(0)*3*maxcontsshi, &
 564 !        ivec_displ(0)*3*maxcontsshi, &
 565 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 566 !        write(2,*) "After MPI_SHI"
 567 !        call flush(iout)
 568         iii=0
 569         jjj=0
 570         do i=1,nres
 571          fac_shield(i)=fac_shieldbuf(i)
 572          ishield_list(i)=ishield_listbuf(i)
 573 !         write(iout,*) i,fac_shield(i)
 574          do j=1,3
 575          iii=iii+1
 576          grad_shield(j,i)=grad_shieldbuf2(iii)
 577          enddo !j
 578          do j=1,ishield_list(i)
 579 !          write (iout,*) "ishild", ishield_list(i),i
 580            shield_list(j,i)=shield_listbuf(j,i)
 581           enddo
 582           do j=1,maxcontsshi
 583           do k=1,3
 584            jjj=jjj+1
 585           grad_shield_loc(k,j,i)=grad_shield_locbuf2(jjj)
 586           grad_shield_side(k,j,i)=grad_shield_sidebuf2(jjj)
 587           enddo !k
 588         enddo !j
 589        enddo !i
 590        endif
 591 #ifdef DEBUG
 592        write(iout,*) "after reduce fac_shield reduce"
 593        do i=1,nres
 594         write(2,*) "fac",itype(i,1),fac_shield(i),grad_shield(1,i)
 595         write(2,*) "list", shield_list(1,i),ishield_list(i), &
 596         grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 597        enddo
 598 #endif
 599 #undef DEBUG
 600        endif
 601
 602
 603
 604 !       print *,"AFTER EGB",ipot,evdw
 605 !mc
 606 !mc Sep-06: egb takes care of dynamic ss bonds too
 607 !mc
 608 !      if (dyn_ss) call dyn_set_nss
 609 !      print *,"Processor",myrank," computed USCSC"
 610 #ifdef TIMING
 611       time01=MPI_Wtime()
 612 #endif
 613       call vec_and_deriv
 614 #ifdef TIMING
 615       time_vec=time_vec+MPI_Wtime()-time01
 616 #endif
 617
 618
 619
 620
 621 !        print *,"Processor",myrank," left VEC_AND_DERIV"
 622       if (ipot.lt.6) then
 623 #ifdef SPLITELE
 624 !         print *,"after ipot if", ipot
 625          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 626              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 627              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 628              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 629 #else
 630          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 631              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 632              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 633              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 634 #endif
 635 !            print *,"just befor eelec call"
 636             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 637 !            print *, "ELEC calc"
 638          else
 639             ees=0.0d0
 640             evdw1=0.0d0
 641             eel_loc=0.0d0
 642             eello_turn3=0.0d0
 643             eello_turn4=0.0d0
 644          endif
 645       else
 646 !        write (iout,*) "Soft-spheer ELEC potential"
 647         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 648          eello_turn4)
 649       endif
 650 !      print *,"Processor",myrank," computed UELEC"
 651 !
 652 ! Calculate excluded-volume interaction energy between peptide groups
 653 ! and side chains.
 654 !
 655 !       write(iout,*) "in etotal calc exc;luded",ipot
 656
 657       if (ipot.lt.6) then
 658        if(wscp.gt.0d0) then
 659         call escp(evdw2,evdw2_14)
 660        else
 661         evdw2=0
 662         evdw2_14=0
 663        endif
 664       else
 665 !        write (iout,*) "Soft-sphere SCP potential"
 666         call escp_soft_sphere(evdw2,evdw2_14)
 667       endif
 668 !        write(iout,*) "in etotal before ebond",ipot
 669
 670 !
 671 ! Calculate the bond-stretching energy
 672 !
 673       call ebond(estr)
 674 !       print *,"EBOND",estr
 675 !       write(iout,*) "in etotal afer ebond",ipot
 676
 677 !
 678 ! Calculate the disulfide-bridge and other energy and the contributions
 679 ! from other distance constraints.
 680 !      print *,'Calling EHPB'
 681       call edis(ehpb)
 682 !elwrite(iout,*) "in etotal afer edis",ipot
 683 !      print *,'EHPB exitted succesfully.'
 684 !
 685 ! Calculate the virtual-bond-angle energy.
 686 !       write(iout,*) "in etotal afer edis",ipot
 687
 688 !      if (wang.gt.0.0d0) then
 689 !        call ebend(ebe,ethetacnstr)
 690 !      else
 691 !        ebe=0
 692 !        ethetacnstr=0
 693 !      endif
 694       if (wang.gt.0d0) then
 695        if (tor_mode.eq.0) then
 696          call ebend(ebe)
 697        else
 698 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 699 !C energy function
 700          call ebend_kcc(ebe)
 701        endif
 702       else
 703         ebe=0.0d0
 704       endif
 705       ethetacnstr=0.0d0
 706       if (with_theta_constr) call etheta_constr(ethetacnstr)
 707
 708 !       write(iout,*) "in etotal afer ebe",ipot
 709
 710 !      print *,"Processor",myrank," computed UB"
 711 !
 712 ! Calculate the SC local energy.
 713 !
 714       call esc(escloc)
 715 !elwrite(iout,*) "in etotal afer esc",ipot
 716 !      print *,"Processor",myrank," computed USC"
 717 !
 718 ! Calculate the virtual-bond torsional energy.
 719 !
 720 !d    print *,'nterm=',nterm
 721 !      if (wtor.gt.0) then
 722 !       call etor(etors,edihcnstr)
 723 !      else
 724 !       etors=0
 725 !       edihcnstr=0
 726 !      endif
 727       if (wtor.gt.0.0d0) then
 728          if (tor_mode.eq.0) then
 729            call etor(etors)
 730          else
 731 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 732 !C energy function
 733            call etor_kcc(etors)
 734          endif
 735       else
 736         etors=0.0d0
 737       endif
 738       edihcnstr=0.0d0
 739       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 740 !c      print *,"Processor",myrank," computed Utor"
 741
 742 !      print *,"Processor",myrank," computed Utor"
 743
 744 !
 745 ! 6/23/01 Calculate double-torsional energy
 746 !
 747 !elwrite(iout,*) "in etotal",ipot
 748       if (wtor_d.gt.0) then
 749        call etor_d(etors_d)
 750       else
 751        etors_d=0
 752       endif
 753 !      print *,"Processor",myrank," computed Utord"
 754 !
 755 ! 21/5/07 Calculate local sicdechain correlation energy
 756 !
 757       if (wsccor.gt.0.0d0) then
 758         call eback_sc_corr(esccor)
 759       else
 760         esccor=0.0d0
 761       endif
 762
 763 !      write(iout,*) "before multibody"
 764       call flush(iout)
 765 !      print *,"Processor",myrank," computed Usccorr"
 766 !
 767 ! 12/1/95 Multi-body terms
 768 !
 769       n_corr=0
 770       n_corr1=0
 771       call flush(iout)
 772       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 773           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 774          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 775 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 776 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 777       else
 778          ecorr=0.0d0
 779          ecorr5=0.0d0
 780          ecorr6=0.0d0
 781          eturn6=0.0d0
 782       endif
 783 !elwrite(iout,*) "in etotal",ipot
 784       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 785          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 786 !d         write (iout,*) "multibody_hb ecorr",ecorr
 787       endif
 788 !      write(iout,*) "afeter  multibody hb"
 789
 790 !      print *,"Processor",myrank," computed Ucorr"
 791 !
 792 ! If performing constraint dynamics, call the constraint energy
 793 !  after the equilibration time
 794       if(usampl.and.totT.gt.eq_time) then
 795 !elwrite(iout,*) "afeter  multibody hb"
 796          call EconstrQ
 797 !elwrite(iout,*) "afeter  multibody hb"
 798          call Econstr_back
 799 !elwrite(iout,*) "afeter  multibody hb"
 800       else
 801          Uconst=0.0d0
 802          Uconst_back=0.0d0
 803       endif
 804       call flush(iout)
 805 !         write(iout,*) "after Econstr"
 806
 807       if (wliptran.gt.0) then
 808 !        print *,"PRZED WYWOLANIEM"
 809         call Eliptransfer(eliptran)
 810       else
 811        eliptran=0.0d0
 812       endif
 813       if (fg_rank.eq.0) then
 814       if (AFMlog.gt.0) then
 815         call AFMforce(Eafmforce)
 816       else if (selfguide.gt.0) then
 817         call AFMvel(Eafmforce)
 818       else
 819         Eafmforce=0.0d0
 820       endif
 821       endif
 822       if (tubemode.eq.1) then
 823        call calctube(etube)
 824       else if (tubemode.eq.2) then
 825        call calctube2(etube)
 826       elseif (tubemode.eq.3) then
 827        call calcnano(etube)
 828       else
 829        etube=0.0d0
 830       endif
 831 !--------------------------------------------------------
 832 !       write (iout,*) "NRES_MOLEC(2),",nres_molec(2)
 833 !      print *,"before",ees,evdw1,ecorr
 834 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 835       if (nres_molec(2).gt.0) then
 836       call ebond_nucl(estr_nucl)
 837       call ebend_nucl(ebe_nucl)
 838       call etor_nucl(etors_nucl)
 839       call esb_gb(evdwsb,eelsb)
 840       call epp_nucl_sub(evdwpp,eespp)
 841       call epsb(evdwpsb,eelpsb)
 842       call esb(esbloc)
 843       call multibody_hb_nucl(ecorr_nucl,ecorr3_nucl,n_corr,n_corr1)
 844       else
 845        etors_nucl=0.0d0
 846        estr_nucl=0.0d0
 847        ecorr3_nucl=0.0d0
 848        ecorr_nucl=0.0d0
 849        ebe_nucl=0.0d0
 850        evdwsb=0.0d0
 851        eelsb=0.0d0
 852        esbloc=0.0d0
 853        evdwpsb=0.0d0
 854        eelpsb=0.0d0
 855        evdwpp=0.0d0
 856        eespp=0.0d0
 857        etors_d_nucl=0.0d0
 858       endif
 859 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 860 !      print *,"before ecatcat",wcatcat
 861       if (nres_molec(5).gt.0) then
 862       if (nfgtasks.gt.1) then
 863       if (fg_rank.eq.0) then
 864       call ecatcat(ecationcation)
 865       endif
 866       else
 867       call ecatcat(ecationcation)
 868       endif
 869       if (oldion.gt.0) then
 870       call ecat_prot(ecation_prot)
 871       else
 872       call ecats_prot_amber(ecation_prot)
 873       endif
 874       else
 875       ecationcation=0.0d0
 876       ecation_prot=0.0d0
 877       endif
 878       if ((nres_molec(2).gt.0).and.(nres_molec(1).gt.0)) then
 879       call eprot_sc_base(escbase)
 880       call epep_sc_base(epepbase)
 881       call eprot_sc_phosphate(escpho)
 882       call eprot_pep_phosphate(epeppho)
 883       else
 884       epepbase=0.0
 885       escbase=0.0
 886       escpho=0.0
 887       epeppho=0.0
 888       endif
 889 !      call ecatcat(ecationcation)
 890 !      print *,"after ebend", wtor_nucl
 891 #ifdef TIMING
 892       time_enecalc=time_enecalc+MPI_Wtime()-time00
 893 #endif
 894 !      print *,"Processor",myrank," computed Uconstr"
 895 #ifdef TIMING
 896       time00=MPI_Wtime()
 897 #endif
 898 !
 899 ! Sum the energies
 900 !
 901       energia(1)=evdw
 902 #ifdef SCP14
 903       energia(2)=evdw2-evdw2_14
 904       energia(18)=evdw2_14
 905 #else
 906       energia(2)=evdw2
 907       energia(18)=0.0d0
 908 #endif
 909 #ifdef SPLITELE
 910       energia(3)=ees
 911       energia(16)=evdw1
 912 #else
 913       energia(3)=ees+evdw1
 914       energia(16)=0.0d0
 915 #endif
 916       energia(4)=ecorr
 917       energia(5)=ecorr5
 918       energia(6)=ecorr6
 919       energia(7)=eel_loc
 920       energia(8)=eello_turn3
 921       energia(9)=eello_turn4
 922       energia(10)=eturn6
 923       energia(11)=ebe
 924       energia(12)=escloc
 925       energia(13)=etors
 926       energia(14)=etors_d
 927       energia(15)=ehpb
 928       energia(19)=edihcnstr
 929       energia(17)=estr
 930       energia(20)=Uconst+Uconst_back
 931       energia(21)=esccor
 932       energia(22)=eliptran
 933       energia(23)=Eafmforce
 934       energia(24)=ethetacnstr
 935       energia(25)=etube
 936 !---------------------------------------------------------------
 937       energia(26)=evdwpp
 938       energia(27)=eespp
 939       energia(28)=evdwpsb
 940       energia(29)=eelpsb
 941       energia(30)=evdwsb
 942       energia(31)=eelsb
 943       energia(32)=estr_nucl
 944       energia(33)=ebe_nucl
 945       energia(34)=esbloc
 946       energia(35)=etors_nucl
 947       energia(36)=etors_d_nucl
 948       energia(37)=ecorr_nucl
 949       energia(38)=ecorr3_nucl
 950 !----------------------------------------------------------------------
 951 !    Here are the energies showed per procesor if the are more processors
 952 !    per molecule then we sum it up in sum_energy subroutine
 953 !      print *," Processor",myrank," calls SUM_ENERGY"
 954       energia(42)=ecation_prot
 955       energia(41)=ecationcation
 956       energia(46)=escbase
 957       energia(47)=epepbase
 958       energia(48)=escpho
 959       energia(49)=epeppho
 960 !      energia(50)=ecations_prot_amber
 961       call sum_energy(energia,.true.)
 962       if (dyn_ss) call dyn_set_nss
 963 !      print *," Processor",myrank," left SUM_ENERGY"
 964 #ifdef TIMING
 965       time_sumene=time_sumene+MPI_Wtime()-time00
 966 #endif
 967 !        call enerprint(energia)
 968 !elwrite(iout,*)"finish etotal"
 969       return
 970       end subroutine etotal
 971 !-----------------------------------------------------------------------------
 972       subroutine sum_energy(energia,reduce)
 973 !      implicit real*8 (a-h,o-z)
 974 !      include 'DIMENSIONS'
 975 #ifndef ISNAN
 976       external proc_proc
 977 #ifdef WINPGI
 978 !MS$ATTRIBUTES C ::  proc_proc
 979 #endif
 980 #endif
 981 #ifdef MPI
 982       include "mpif.h"
 983 #endif
 984 !      include 'COMMON.SETUP'
 985 !      include 'COMMON.IOUNITS'
 986       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 987 !      include 'COMMON.FFIELD'
 988 !      include 'COMMON.DERIV'
 989 !      include 'COMMON.INTERACT'
 990 !      include 'COMMON.SBRIDGE'
 991 !      include 'COMMON.CHAIN'
 992 !      include 'COMMON.VAR'
 993 !      include 'COMMON.CONTROL'
 994 !      include 'COMMON.TIME1'
 995       logical :: reduce
 996       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 997       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 998       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 999         eliptran,etube, Eafmforce,ethetacnstr
1000       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1001                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1002                       ecorr3_nucl
1003       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber
1004       real(kind=8) :: escbase,epepbase,escpho,epeppho
1005       integer :: i
1006 #ifdef MPI
1007       integer :: ierr
1008       real(kind=8) :: time00
1009       if (nfgtasks.gt.1 .and. reduce) then
1010
1011 #ifdef DEBUG
1012         write (iout,*) "energies before REDUCE"
1013         call enerprint(energia)
1014         call flush(iout)
1015 #endif
1016         do i=0,n_ene
1017           enebuff(i)=energia(i)
1018         enddo
1019         time00=MPI_Wtime()
1020         call MPI_Barrier(FG_COMM,IERR)
1021         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
1022         time00=MPI_Wtime()
1023         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
1024           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1025 #ifdef DEBUG
1026         write (iout,*) "energies after REDUCE"
1027         call enerprint(energia)
1028         call flush(iout)
1029 #endif
1030         time_Reduce=time_Reduce+MPI_Wtime()-time00
1031       endif
1032       if (fg_rank.eq.0) then
1033 #endif
1034       evdw=energia(1)
1035 #ifdef SCP14
1036       evdw2=energia(2)+energia(18)
1037       evdw2_14=energia(18)
1038 #else
1039       evdw2=energia(2)
1040 #endif
1041 #ifdef SPLITELE
1042       ees=energia(3)
1043       evdw1=energia(16)
1044 #else
1045       ees=energia(3)
1046       evdw1=0.0d0
1047 #endif
1048       ecorr=energia(4)
1049       ecorr5=energia(5)
1050       ecorr6=energia(6)
1051       eel_loc=energia(7)
1052       eello_turn3=energia(8)
1053       eello_turn4=energia(9)
1054       eturn6=energia(10)
1055       ebe=energia(11)
1056       escloc=energia(12)
1057       etors=energia(13)
1058       etors_d=energia(14)
1059       ehpb=energia(15)
1060       edihcnstr=energia(19)
1061       estr=energia(17)
1062       Uconst=energia(20)
1063       esccor=energia(21)
1064       eliptran=energia(22)
1065       Eafmforce=energia(23)
1066       ethetacnstr=energia(24)
1067       etube=energia(25)
1068       evdwpp=energia(26)
1069       eespp=energia(27)
1070       evdwpsb=energia(28)
1071       eelpsb=energia(29)
1072       evdwsb=energia(30)
1073       eelsb=energia(31)
1074       estr_nucl=energia(32)
1075       ebe_nucl=energia(33)
1076       esbloc=energia(34)
1077       etors_nucl=energia(35)
1078       etors_d_nucl=energia(36)
1079       ecorr_nucl=energia(37)
1080       ecorr3_nucl=energia(38)
1081       ecation_prot=energia(42)
1082       ecationcation=energia(41)
1083       escbase=energia(46)
1084       epepbase=energia(47)
1085       escpho=energia(48)
1086       epeppho=energia(49)
1087 !      ecations_prot_amber=energia(50)
1088
1089 !      energia(41)=ecation_prot
1090 !      energia(42)=ecationcation
1091
1092
1093 #ifdef SPLITELE
1094       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
1095        +wang*ebe+wtor*etors+wscloc*escloc &
1096        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1097        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1098        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1099        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1100        +Eafmforce+ethetacnstr  &
1101        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1102        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1103        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1104        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1105        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1106        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
1107 #else
1108       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
1109        +wang*ebe+wtor*etors+wscloc*escloc &
1110        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1111        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1112        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1113        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1114        +Eafmforce+ethetacnstr &
1115        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1116        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1117        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1118        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1119        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1120        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
1121 #endif
1122       energia(0)=etot
1123 ! detecting NaNQ
1124 #ifdef ISNAN
1125 #ifdef AIX
1126       if (isnan(etot).ne.0) energia(0)=1.0d+99
1127 #else
1128       if (isnan(etot)) energia(0)=1.0d+99
1129 #endif
1130 #else
1131       i=0
1132 #ifdef WINPGI
1133       idumm=proc_proc(etot,i)
1134 #else
1135       call proc_proc(etot,i)
1136 #endif
1137       if(i.eq.1)energia(0)=1.0d+99
1138 #endif
1139 #ifdef MPI
1140       endif
1141 #endif
1142 !      call enerprint(energia)
1143       call flush(iout)
1144       return
1145       end subroutine sum_energy
1146 !-----------------------------------------------------------------------------
1147       subroutine rescale_weights(t_bath)
1148 !      implicit real*8 (a-h,o-z)
1149 #ifdef MPI
1150       include 'mpif.h'
1151 #endif
1152 !      include 'DIMENSIONS'
1153 !      include 'COMMON.IOUNITS'
1154 !      include 'COMMON.FFIELD'
1155 !      include 'COMMON.SBRIDGE'
1156       real(kind=8) :: kfac=2.4d0
1157       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
1158 !el local variables
1159       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
1160       real(kind=8) :: T0=3.0d2
1161       integer :: ierror
1162 !      facT=temp0/t_bath
1163 !      facT=2*temp0/(t_bath+temp0)
1164       if (rescale_mode.eq.0) then
1165         facT(1)=1.0d0
1166         facT(2)=1.0d0
1167         facT(3)=1.0d0
1168         facT(4)=1.0d0
1169         facT(5)=1.0d0
1170         facT(6)=1.0d0
1171       else if (rescale_mode.eq.1) then
1172         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
1173         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1174         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1175         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1176         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1177 #ifdef WHAM_RUN
1178 !#if defined(WHAM_RUN) || defined(CLUSTER)
1179 #if defined(FUNCTH)
1180 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
1181         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1182 #elif defined(FUNCT)
1183         facT(6)=t_bath/T0
1184 #else
1185         facT(6)=1.0d0
1186 #endif
1187 #endif
1188       else if (rescale_mode.eq.2) then
1189         x=t_bath/temp0
1190         x2=x*x
1191         x3=x2*x
1192         x4=x3*x
1193         x5=x4*x
1194         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
1195         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
1196         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
1197         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
1198         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
1199 #ifdef WHAM_RUN
1200 !#if defined(WHAM_RUN) || defined(CLUSTER)
1201 #if defined(FUNCTH)
1202         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1203 #elif defined(FUNCT)
1204         facT(6)=t_bath/T0
1205 #else
1206         facT(6)=1.0d0
1207 #endif
1208 #endif
1209       else
1210         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1211         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1212 #ifdef MPI
1213        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1214 #endif
1215        stop 555
1216       endif
1217       welec=weights(3)*fact(1)
1218       wcorr=weights(4)*fact(3)
1219       wcorr5=weights(5)*fact(4)
1220       wcorr6=weights(6)*fact(5)
1221       wel_loc=weights(7)*fact(2)
1222       wturn3=weights(8)*fact(2)
1223       wturn4=weights(9)*fact(3)
1224       wturn6=weights(10)*fact(5)
1225       wtor=weights(13)*fact(1)
1226       wtor_d=weights(14)*fact(2)
1227       wsccor=weights(21)*fact(1)
1228       welpsb=weights(28)*fact(1)
1229       wcorr_nucl= weights(37)*fact(1)
1230       wcorr3_nucl=weights(38)*fact(2)
1231       wtor_nucl=  weights(35)*fact(1)
1232       wtor_d_nucl=weights(36)*fact(2)
1233       wpepbase=weights(47)*fact(1)
1234       return
1235       end subroutine rescale_weights
1236 !-----------------------------------------------------------------------------
1237       subroutine enerprint(energia)
1238 !      implicit real*8 (a-h,o-z)
1239 !      include 'DIMENSIONS'
1240 !      include 'COMMON.IOUNITS'
1241 !      include 'COMMON.FFIELD'
1242 !      include 'COMMON.SBRIDGE'
1243 !      include 'COMMON.MD'
1244       real(kind=8) :: energia(0:n_ene)
1245 !el local variables
1246       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
1247       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
1248       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
1249        etube,ethetacnstr,Eafmforce
1250       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1251                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1252                       ecorr3_nucl
1253       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber
1254       real(kind=8) :: escbase,epepbase,escpho,epeppho
1255
1256       etot=energia(0)
1257       evdw=energia(1)
1258       evdw2=energia(2)
1259 #ifdef SCP14
1260       evdw2=energia(2)+energia(18)
1261 #else
1262       evdw2=energia(2)
1263 #endif
1264       ees=energia(3)
1265 #ifdef SPLITELE
1266       evdw1=energia(16)
1267 #endif
1268       ecorr=energia(4)
1269       ecorr5=energia(5)
1270       ecorr6=energia(6)
1271       eel_loc=energia(7)
1272       eello_turn3=energia(8)
1273       eello_turn4=energia(9)
1274       eello_turn6=energia(10)
1275       ebe=energia(11)
1276       escloc=energia(12)
1277       etors=energia(13)
1278       etors_d=energia(14)
1279       ehpb=energia(15)
1280       edihcnstr=energia(19)
1281       estr=energia(17)
1282       Uconst=energia(20)
1283       esccor=energia(21)
1284       eliptran=energia(22)
1285       Eafmforce=energia(23)
1286       ethetacnstr=energia(24)
1287       etube=energia(25)
1288       evdwpp=energia(26)
1289       eespp=energia(27)
1290       evdwpsb=energia(28)
1291       eelpsb=energia(29)
1292       evdwsb=energia(30)
1293       eelsb=energia(31)
1294       estr_nucl=energia(32)
1295       ebe_nucl=energia(33)
1296       esbloc=energia(34)
1297       etors_nucl=energia(35)
1298       etors_d_nucl=energia(36)
1299       ecorr_nucl=energia(37)
1300       ecorr3_nucl=energia(38)
1301       ecation_prot=energia(42)
1302       ecationcation=energia(41)
1303       escbase=energia(46)
1304       epepbase=energia(47)
1305       escpho=energia(48)
1306       epeppho=energia(49)
1307 !      ecations_prot_amber=energia(50)
1308 #ifdef SPLITELE
1309       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
1310         estr,wbond,ebe,wang,&
1311         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1312         ecorr,wcorr,&
1313         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1314         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
1315         edihcnstr,ethetacnstr,ebr*nss,&
1316         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
1317         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
1318         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1319         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1320         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1321         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat, &
1322         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1323         etot
1324    10 format (/'Virtual-chain energies:'// &
1325        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1326        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1327        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1328        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
1329        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1330        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1331        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1332        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1333        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1334        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1335        ' (SS bridges & dist. cnstr.)'/ &
1336        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1337        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1338        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1339        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1340        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1341        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1342        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1343        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1344        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1345        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1346        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1347        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1348        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1349        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1350        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1351        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1352        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1353        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1354        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1355        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1356        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1357        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1358        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1359        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1360        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1361        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1362        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1363        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1364        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1365        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1366        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1367        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1368        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1369        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1370        'ETOT=  ',1pE16.6,' (total)')
1371 #else
1372       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1373         estr,wbond,ebe,wang,&
1374         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1375         ecorr,wcorr,&
1376         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1377         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1378         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforce,     &
1379         etube,wtube, &
1380         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1381         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1382         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1383         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1384         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat,  &
1385         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1386         etot
1387    10 format (/'Virtual-chain energies:'// &
1388        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1389        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1390        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1391        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1392        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1393        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1394        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1395        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1396        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1397        ' (SS bridges & dist. cnstr.)'/ &
1398        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1399        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1400        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1401        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1402        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1403        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1404        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1405        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1406        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1407        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1408        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1409        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1410        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1411        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1412        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1413        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1414        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1415        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1416        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1417        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1418        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1419        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1420        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1421        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1422        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1423        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1424        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1425        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1426        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1427        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1428        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1429        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1430        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1431        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1432        'ETOT=  ',1pE16.6,' (total)')
1433 #endif
1434       return
1435       end subroutine enerprint
1436 !-----------------------------------------------------------------------------
1437       subroutine elj(evdw)
1438 !
1439 ! This subroutine calculates the interaction energy of nonbonded side chains
1440 ! assuming the LJ potential of interaction.
1441 !
1442 !      implicit real*8 (a-h,o-z)
1443 !      include 'DIMENSIONS'
1444       real(kind=8),parameter :: accur=1.0d-10
1445 !      include 'COMMON.GEO'
1446 !      include 'COMMON.VAR'
1447 !      include 'COMMON.LOCAL'
1448 !      include 'COMMON.CHAIN'
1449 !      include 'COMMON.DERIV'
1450 !      include 'COMMON.INTERACT'
1451 !      include 'COMMON.TORSION'
1452 !      include 'COMMON.SBRIDGE'
1453 !      include 'COMMON.NAMES'
1454 !      include 'COMMON.IOUNITS'
1455 !      include 'COMMON.CONTACTS'
1456       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1457       integer :: num_conti
1458 !el local variables
1459       integer :: i,itypi,iint,j,itypi1,itypj,k
1460       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij,sslipi,ssgradlipi,&
1461        aa,bb,sslipj,ssgradlipj
1462       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1463       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1464
1465 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1466       evdw=0.0D0
1467 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1468 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1469 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1470 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1471
1472       do i=iatsc_s,iatsc_e
1473         itypi=iabs(itype(i,1))
1474         if (itypi.eq.ntyp1) cycle
1475         itypi1=iabs(itype(i+1,1))
1476         xi=c(1,nres+i)
1477         yi=c(2,nres+i)
1478         zi=c(3,nres+i)
1479         call to_box(xi,yi,zi)
1480         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1481
1482 ! Change 12/1/95
1483         num_conti=0
1484 !
1485 ! Calculate SC interaction energy.
1486 !
1487         do iint=1,nint_gr(i)
1488 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1489 !d   &                  'iend=',iend(i,iint)
1490           do j=istart(i,iint),iend(i,iint)
1491             itypj=iabs(itype(j,1))
1492             if (itypj.eq.ntyp1) cycle
1493             xj=c(1,nres+j)-xi
1494             yj=c(2,nres+j)-yi
1495             zj=c(3,nres+j)-zi
1496             call to_box(xj,yj,zj)
1497             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1498             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1499              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1500             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1501              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1502             xj=boxshift(xj-xi,boxxsize)
1503             yj=boxshift(yj-yi,boxysize)
1504             zj=boxshift(zj-zi,boxzsize)
1505 ! Change 12/1/95 to calculate four-body interactions
1506             rij=xj*xj+yj*yj+zj*zj
1507             rrij=1.0D0/rij
1508 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1509             eps0ij=eps(itypi,itypj)
1510             fac=rrij**expon2
1511             e1=fac*fac*aa_aq(itypi,itypj)
1512             e2=fac*bb_aq(itypi,itypj)
1513             evdwij=e1+e2
1514 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1515 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1516 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1517 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1518 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1519 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1520             evdw=evdw+evdwij
1521 !
1522 ! Calculate the components of the gradient in DC and X
1523 !
1524             fac=-rrij*(e1+evdwij)
1525             gg(1)=xj*fac
1526             gg(2)=yj*fac
1527             gg(3)=zj*fac
1528             do k=1,3
1529               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1530               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1531               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1532               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1533             enddo
1534 !grad            do k=i,j-1
1535 !grad              do l=1,3
1536 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1537 !grad              enddo
1538 !grad            enddo
1539 !
1540 ! 12/1/95, revised on 5/20/97
1541 !
1542 ! Calculate the contact function. The ith column of the array JCONT will
1543 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1544 ! greater than I). The arrays FACONT and GACONT will contain the values of
1545 ! the contact function and its derivative.
1546 !
1547 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1548 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1549 ! Uncomment next line, if the correlation interactions are contact function only
1550             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1551               rij=dsqrt(rij)
1552               sigij=sigma(itypi,itypj)
1553               r0ij=rs0(itypi,itypj)
1554 !
1555 ! Check whether the SC's are not too far to make a contact.
1556 !
1557               rcut=1.5d0*r0ij
1558               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1559 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1560 !
1561               if (fcont.gt.0.0D0) then
1562 ! If the SC-SC distance if close to sigma, apply spline.
1563 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1564 !Adam &             fcont1,fprimcont1)
1565 !Adam           fcont1=1.0d0-fcont1
1566 !Adam           if (fcont1.gt.0.0d0) then
1567 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1568 !Adam             fcont=fcont*fcont1
1569 !Adam           endif
1570 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1571 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1572 !ga             do k=1,3
1573 !ga               gg(k)=gg(k)*eps0ij
1574 !ga             enddo
1575 !ga             eps0ij=-evdwij*eps0ij
1576 ! Uncomment for AL's type of SC correlation interactions.
1577 !adam           eps0ij=-evdwij
1578                 num_conti=num_conti+1
1579                 jcont(num_conti,i)=j
1580                 facont(num_conti,i)=fcont*eps0ij
1581                 fprimcont=eps0ij*fprimcont/rij
1582                 fcont=expon*fcont
1583 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1584 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1585 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1586 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1587                 gacont(1,num_conti,i)=-fprimcont*xj
1588                 gacont(2,num_conti,i)=-fprimcont*yj
1589                 gacont(3,num_conti,i)=-fprimcont*zj
1590 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1591 !d              write (iout,'(2i3,3f10.5)')
1592 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1593               endif
1594             endif
1595           enddo      ! j
1596         enddo        ! iint
1597 ! Change 12/1/95
1598         num_cont(i)=num_conti
1599       enddo          ! i
1600       do i=1,nct
1601         do j=1,3
1602           gvdwc(j,i)=expon*gvdwc(j,i)
1603           gvdwx(j,i)=expon*gvdwx(j,i)
1604         enddo
1605       enddo
1606 !******************************************************************************
1607 !
1608 !                              N O T E !!!
1609 !
1610 ! To save time, the factor of EXPON has been extracted from ALL components
1611 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1612 ! use!
1613 !
1614 !******************************************************************************
1615       return
1616       end subroutine elj
1617 !-----------------------------------------------------------------------------
1618       subroutine eljk(evdw)
1619 !
1620 ! This subroutine calculates the interaction energy of nonbonded side chains
1621 ! assuming the LJK potential of interaction.
1622 !
1623 !      implicit real*8 (a-h,o-z)
1624 !      include 'DIMENSIONS'
1625 !      include 'COMMON.GEO'
1626 !      include 'COMMON.VAR'
1627 !      include 'COMMON.LOCAL'
1628 !      include 'COMMON.CHAIN'
1629 !      include 'COMMON.DERIV'
1630 !      include 'COMMON.INTERACT'
1631 !      include 'COMMON.IOUNITS'
1632 !      include 'COMMON.NAMES'
1633       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1634       logical :: scheck
1635 !el local variables
1636       integer :: i,iint,j,itypi,itypi1,k,itypj
1637       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij, &
1638          sslipi,ssgradlipi, sslipj,ssgradlipj, aa, bb
1639       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1640
1641 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1642       evdw=0.0D0
1643       do i=iatsc_s,iatsc_e
1644         itypi=iabs(itype(i,1))
1645         if (itypi.eq.ntyp1) cycle
1646         itypi1=iabs(itype(i+1,1))
1647         xi=c(1,nres+i)
1648         yi=c(2,nres+i)
1649         zi=c(3,nres+i)
1650         call to_box(xi,yi,zi)
1651         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1652
1653 !
1654 ! Calculate SC interaction energy.
1655 !
1656         do iint=1,nint_gr(i)
1657           do j=istart(i,iint),iend(i,iint)
1658             itypj=iabs(itype(j,1))
1659             if (itypj.eq.ntyp1) cycle
1660             xj=c(1,nres+j)-xi
1661             yj=c(2,nres+j)-yi
1662             zj=c(3,nres+j)-zi
1663             call to_box(xj,yj,zj)
1664             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1665             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1666              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1667             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1668              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1669             xj=boxshift(xj-xi,boxxsize)
1670             yj=boxshift(yj-yi,boxysize)
1671             zj=boxshift(zj-zi,boxzsize)
1672             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1673             fac_augm=rrij**expon
1674             e_augm=augm(itypi,itypj)*fac_augm
1675             r_inv_ij=dsqrt(rrij)
1676             rij=1.0D0/r_inv_ij
1677             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1678             fac=r_shift_inv**expon
1679             e1=fac*fac*aa_aq(itypi,itypj)
1680             e2=fac*bb_aq(itypi,itypj)
1681             evdwij=e_augm+e1+e2
1682 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1683 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1684 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1685 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1686 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1687 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1688 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1689             evdw=evdw+evdwij
1690 !
1691 ! Calculate the components of the gradient in DC and X
1692 !
1693             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1694             gg(1)=xj*fac
1695             gg(2)=yj*fac
1696             gg(3)=zj*fac
1697             do k=1,3
1698               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1699               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1700               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1701               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1702             enddo
1703 !grad            do k=i,j-1
1704 !grad              do l=1,3
1705 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1706 !grad              enddo
1707 !grad            enddo
1708           enddo      ! j
1709         enddo        ! iint
1710       enddo          ! i
1711       do i=1,nct
1712         do j=1,3
1713           gvdwc(j,i)=expon*gvdwc(j,i)
1714           gvdwx(j,i)=expon*gvdwx(j,i)
1715         enddo
1716       enddo
1717       return
1718       end subroutine eljk
1719 !-----------------------------------------------------------------------------
1720       subroutine ebp(evdw)
1721 !
1722 ! This subroutine calculates the interaction energy of nonbonded side chains
1723 ! assuming the Berne-Pechukas potential of interaction.
1724 !
1725       use comm_srutu
1726       use calc_data
1727 !      implicit real*8 (a-h,o-z)
1728 !      include 'DIMENSIONS'
1729 !      include 'COMMON.GEO'
1730 !      include 'COMMON.VAR'
1731 !      include 'COMMON.LOCAL'
1732 !      include 'COMMON.CHAIN'
1733 !      include 'COMMON.DERIV'
1734 !      include 'COMMON.NAMES'
1735 !      include 'COMMON.INTERACT'
1736 !      include 'COMMON.IOUNITS'
1737 !      include 'COMMON.CALC'
1738       use comm_srutu
1739 !el      integer :: icall
1740 !el      common /srutu/ icall
1741 !     double precision rrsave(maxdim)
1742       logical :: lprn
1743 !el local variables
1744       integer :: iint,itypi,itypi1,itypj
1745       real(kind=8) :: rrij,xi,yi,zi, sslipi,ssgradlipi, sslipj, &
1746         ssgradlipj, aa, bb
1747       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1748
1749 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1750       evdw=0.0D0
1751 !     if (icall.eq.0) then
1752 !       lprn=.true.
1753 !     else
1754         lprn=.false.
1755 !     endif
1756 !el      ind=0
1757       do i=iatsc_s,iatsc_e
1758         itypi=iabs(itype(i,1))
1759         if (itypi.eq.ntyp1) cycle
1760         itypi1=iabs(itype(i+1,1))
1761         xi=c(1,nres+i)
1762         yi=c(2,nres+i)
1763         zi=c(3,nres+i)
1764         call to_box(xi,yi,zi)
1765         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1766         dxi=dc_norm(1,nres+i)
1767         dyi=dc_norm(2,nres+i)
1768         dzi=dc_norm(3,nres+i)
1769 !        dsci_inv=dsc_inv(itypi)
1770         dsci_inv=vbld_inv(i+nres)
1771 !
1772 ! Calculate SC interaction energy.
1773 !
1774         do iint=1,nint_gr(i)
1775           do j=istart(i,iint),iend(i,iint)
1776 !el            ind=ind+1
1777             itypj=iabs(itype(j,1))
1778             if (itypj.eq.ntyp1) cycle
1779 !            dscj_inv=dsc_inv(itypj)
1780             dscj_inv=vbld_inv(j+nres)
1781             chi1=chi(itypi,itypj)
1782             chi2=chi(itypj,itypi)
1783             chi12=chi1*chi2
1784             chip1=chip(itypi)
1785             chip2=chip(itypj)
1786             chip12=chip1*chip2
1787             alf1=alp(itypi)
1788             alf2=alp(itypj)
1789             alf12=0.5D0*(alf1+alf2)
1790 ! For diagnostics only!!!
1791 !           chi1=0.0D0
1792 !           chi2=0.0D0
1793 !           chi12=0.0D0
1794 !           chip1=0.0D0
1795 !           chip2=0.0D0
1796 !           chip12=0.0D0
1797 !           alf1=0.0D0
1798 !           alf2=0.0D0
1799 !           alf12=0.0D0
1800             xj=c(1,nres+j)-xi
1801             yj=c(2,nres+j)-yi
1802             zj=c(3,nres+j)-zi
1803             call to_box(xj,yj,zj)
1804             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1805             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1806              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1807             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1808              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1809             xj=boxshift(xj-xi,boxxsize)
1810             yj=boxshift(yj-yi,boxysize)
1811             zj=boxshift(zj-zi,boxzsize)
1812             dxj=dc_norm(1,nres+j)
1813             dyj=dc_norm(2,nres+j)
1814             dzj=dc_norm(3,nres+j)
1815             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1816 !d          if (icall.eq.0) then
1817 !d            rrsave(ind)=rrij
1818 !d          else
1819 !d            rrij=rrsave(ind)
1820 !d          endif
1821             rij=dsqrt(rrij)
1822 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1823             call sc_angular
1824 ! Calculate whole angle-dependent part of epsilon and contributions
1825 ! to its derivatives
1826             fac=(rrij*sigsq)**expon2
1827             e1=fac*fac*aa_aq(itypi,itypj)
1828             e2=fac*bb_aq(itypi,itypj)
1829             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1830             eps2der=evdwij*eps3rt
1831             eps3der=evdwij*eps2rt
1832             evdwij=evdwij*eps2rt*eps3rt
1833             evdw=evdw+evdwij
1834             if (lprn) then
1835             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1836             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1837 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1838 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1839 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1840 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1841 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1842 !d     &        evdwij
1843             endif
1844 ! Calculate gradient components.
1845             e1=e1*eps1*eps2rt**2*eps3rt**2
1846             fac=-expon*(e1+evdwij)
1847             sigder=fac/sigsq
1848             fac=rrij*fac
1849 ! Calculate radial part of the gradient
1850             gg(1)=xj*fac
1851             gg(2)=yj*fac
1852             gg(3)=zj*fac
1853 ! Calculate the angular part of the gradient and sum add the contributions
1854 ! to the appropriate components of the Cartesian gradient.
1855             call sc_grad
1856           enddo      ! j
1857         enddo        ! iint
1858       enddo          ! i
1859 !     stop
1860       return
1861       end subroutine ebp
1862 !-----------------------------------------------------------------------------
1863       subroutine egb(evdw)
1864 !
1865 ! This subroutine calculates the interaction energy of nonbonded side chains
1866 ! assuming the Gay-Berne potential of interaction.
1867 !
1868       use calc_data
1869 !      implicit real*8 (a-h,o-z)
1870 !      include 'DIMENSIONS'
1871 !      include 'COMMON.GEO'
1872 !      include 'COMMON.VAR'
1873 !      include 'COMMON.LOCAL'
1874 !      include 'COMMON.CHAIN'
1875 !      include 'COMMON.DERIV'
1876 !      include 'COMMON.NAMES'
1877 !      include 'COMMON.INTERACT'
1878 !      include 'COMMON.IOUNITS'
1879 !      include 'COMMON.CALC'
1880 !      include 'COMMON.CONTROL'
1881 !      include 'COMMON.SBRIDGE'
1882       logical :: lprn
1883 !el local variables
1884       integer :: iint,itypi,itypi1,itypj,subchap,icont
1885       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1886       real(kind=8) :: evdw,sig0ij
1887       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1888                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1889                     sslipi,sslipj,faclip
1890       integer :: ii
1891       real(kind=8) :: fracinbuf
1892
1893 !cccc      energy_dec=.false.
1894 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1895       evdw=0.0D0
1896       lprn=.false.
1897 !     if (icall.eq.0) lprn=.false.
1898 !el      ind=0
1899       dCAVdOM2=0.0d0
1900       dGCLdOM2=0.0d0
1901       dPOLdOM2=0.0d0
1902       dCAVdOM1=0.0d0
1903       dGCLdOM1=0.0d0
1904       dPOLdOM1=0.0d0
1905
1906
1907       do icont=g_listscsc_start,g_listscsc_end
1908       i=newcontlisti(icont)
1909       j=newcontlistj(icont)
1910
1911 !      do i=iatsc_s,iatsc_e
1912 !C        print *,"I am in EVDW",i
1913         itypi=iabs(itype(i,1))
1914 !        if (i.ne.47) cycle
1915         if (itypi.eq.ntyp1) cycle
1916         itypi1=iabs(itype(i+1,1))
1917         xi=c(1,nres+i)
1918         yi=c(2,nres+i)
1919         zi=c(3,nres+i)
1920         call to_box(xi,yi,zi)
1921         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1922
1923         dxi=dc_norm(1,nres+i)
1924         dyi=dc_norm(2,nres+i)
1925         dzi=dc_norm(3,nres+i)
1926 !        dsci_inv=dsc_inv(itypi)
1927         dsci_inv=vbld_inv(i+nres)
1928 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1929 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1930 !
1931 ! Calculate SC interaction energy.
1932 !
1933 !        do iint=1,nint_gr(i)
1934 !          do j=istart(i,iint),iend(i,iint)
1935             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1936               call dyn_ssbond_ene(i,j,evdwij)
1937               evdw=evdw+evdwij
1938               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1939                               'evdw',i,j,evdwij,' ss'
1940 !              if (energy_dec) write (iout,*) &
1941 !                              'evdw',i,j,evdwij,' ss'
1942              do k=j+1,iend(i,iint)
1943 !C search over all next residues
1944               if (dyn_ss_mask(k)) then
1945 !C check if they are cysteins
1946 !C              write(iout,*) 'k=',k
1947
1948 !c              write(iout,*) "PRZED TRI", evdwij
1949 !               evdwij_przed_tri=evdwij
1950               call triple_ssbond_ene(i,j,k,evdwij)
1951 !c               if(evdwij_przed_tri.ne.evdwij) then
1952 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1953 !c               endif
1954
1955 !c              write(iout,*) "PO TRI", evdwij
1956 !C call the energy function that removes the artifical triple disulfide
1957 !C bond the soubroutine is located in ssMD.F
1958               evdw=evdw+evdwij
1959               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1960                             'evdw',i,j,evdwij,'tss'
1961               endif!dyn_ss_mask(k)
1962              enddo! k
1963             ELSE
1964 !el            ind=ind+1
1965             itypj=iabs(itype(j,1))
1966             if (itypj.eq.ntyp1) cycle
1967 !             if (j.ne.78) cycle
1968 !            dscj_inv=dsc_inv(itypj)
1969             dscj_inv=vbld_inv(j+nres)
1970 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1971 !              1.0d0/vbld(j+nres) !d
1972 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1973             sig0ij=sigma(itypi,itypj)
1974             chi1=chi(itypi,itypj)
1975             chi2=chi(itypj,itypi)
1976             chi12=chi1*chi2
1977             chip1=chip(itypi)
1978             chip2=chip(itypj)
1979             chip12=chip1*chip2
1980             alf1=alp(itypi)
1981             alf2=alp(itypj)
1982             alf12=0.5D0*(alf1+alf2)
1983 ! For diagnostics only!!!
1984 !           chi1=0.0D0
1985 !           chi2=0.0D0
1986 !           chi12=0.0D0
1987 !           chip1=0.0D0
1988 !           chip2=0.0D0
1989 !           chip12=0.0D0
1990 !           alf1=0.0D0
1991 !           alf2=0.0D0
1992 !           alf12=0.0D0
1993            xj=c(1,nres+j)
1994            yj=c(2,nres+j)
1995            zj=c(3,nres+j)
1996               call to_box(xj,yj,zj)
1997               call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1998               aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1999                +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2000               bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2001                +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2002               xj=boxshift(xj-xi,boxxsize)
2003               yj=boxshift(yj-yi,boxysize)
2004               zj=boxshift(zj-zi,boxzsize)
2005             dxj=dc_norm(1,nres+j)
2006             dyj=dc_norm(2,nres+j)
2007             dzj=dc_norm(3,nres+j)
2008 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2009 !            write (iout,*) "j",j," dc_norm",& !d
2010 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2011 !          write(iout,*)"rrij ",rrij
2012 !          write(iout,*)"xj yj zj ", xj, yj, zj
2013 !          write(iout,*)"xi yi zi ", xi, yi, zi
2014 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
2015             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2016             rij=dsqrt(rrij)
2017             sss_ele_cut=sscale_ele(1.0d0/(rij))
2018             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
2019 !            print *,sss_ele_cut,sss_ele_grad,&
2020 !            1.0d0/(rij),r_cut_ele,rlamb_ele
2021             if (sss_ele_cut.le.0.0) cycle
2022 ! Calculate angle-dependent terms of energy and contributions to their
2023 ! derivatives.
2024             call sc_angular
2025             sigsq=1.0D0/sigsq
2026             sig=sig0ij*dsqrt(sigsq)
2027             rij_shift=1.0D0/rij-sig+sig0ij
2028 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
2029 !            "sig0ij",sig0ij
2030 ! for diagnostics; uncomment
2031 !            rij_shift=1.2*sig0ij
2032 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2033             if (rij_shift.le.0.0D0) then
2034               evdw=1.0D20
2035 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2036 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
2037 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2038               return
2039             endif
2040             sigder=-sig*sigsq
2041 !---------------------------------------------------------------
2042             rij_shift=1.0D0/rij_shift
2043             fac=rij_shift**expon
2044             faclip=fac
2045             e1=fac*fac*aa!(itypi,itypj)
2046             e2=fac*bb!(itypi,itypj)
2047             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2048             eps2der=evdwij*eps3rt
2049             eps3der=evdwij*eps2rt
2050 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
2051 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
2052 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
2053             evdwij=evdwij*eps2rt*eps3rt
2054             evdw=evdw+evdwij*sss_ele_cut
2055             if (lprn) then
2056             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2057             epsi=bb**2/aa!(itypi,itypj)
2058             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2059               restyp(itypi,1),i,restyp(itypj,1),j, &
2060               epsi,sigm,chi1,chi2,chip1,chip2, &
2061               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
2062               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
2063               evdwij
2064             endif
2065
2066             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
2067                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
2068 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
2069 !            if (energy_dec) write (iout,*) &
2070 !                             'evdw',i,j,evdwij
2071 !                       print *,"ZALAMKA", evdw
2072
2073 ! Calculate gradient components.
2074             e1=e1*eps1*eps2rt**2*eps3rt**2
2075             fac=-expon*(e1+evdwij)*rij_shift
2076             sigder=fac*sigder
2077             fac=rij*fac
2078 !            print *,'before fac',fac,rij,evdwij
2079             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
2080             *rij
2081 !            print *,'grad part scale',fac,   &
2082 !             evdwij*sss_ele_grad/sss_ele_cut &
2083 !            /sigma(itypi,itypj)*rij
2084 !            fac=0.0d0
2085 ! Calculate the radial part of the gradient
2086             gg(1)=xj*fac
2087             gg(2)=yj*fac
2088             gg(3)=zj*fac
2089 !C Calculate the radial part of the gradient
2090             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
2091        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
2092         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
2093        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2094             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2095             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2096
2097 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
2098 ! Calculate angular part of the gradient.
2099             call sc_grad
2100             ENDIF    ! dyn_ss
2101 !          enddo      ! j
2102 !        enddo        ! iint
2103       enddo          ! i
2104 !       print *,"ZALAMKA", evdw
2105 !      write (iout,*) "Number of loop steps in EGB:",ind
2106 !ccc      energy_dec=.false.
2107       return
2108       end subroutine egb
2109 !-----------------------------------------------------------------------------
2110       subroutine egbv(evdw)
2111 !
2112 ! This subroutine calculates the interaction energy of nonbonded side chains
2113 ! assuming the Gay-Berne-Vorobjev potential of interaction.
2114 !
2115       use comm_srutu
2116       use calc_data
2117 !      implicit real*8 (a-h,o-z)
2118 !      include 'DIMENSIONS'
2119 !      include 'COMMON.GEO'
2120 !      include 'COMMON.VAR'
2121 !      include 'COMMON.LOCAL'
2122 !      include 'COMMON.CHAIN'
2123 !      include 'COMMON.DERIV'
2124 !      include 'COMMON.NAMES'
2125 !      include 'COMMON.INTERACT'
2126 !      include 'COMMON.IOUNITS'
2127 !      include 'COMMON.CALC'
2128       use comm_srutu
2129 !el      integer :: icall
2130 !el      common /srutu/ icall
2131       logical :: lprn
2132 !el local variables
2133       integer :: iint,itypi,itypi1,itypj
2134       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2, &
2135          sigm,sslipi,ssgradlipi, sslipj,ssgradlipj, aa, bb
2136       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
2137
2138 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2139       evdw=0.0D0
2140       lprn=.false.
2141 !     if (icall.eq.0) lprn=.true.
2142 !el      ind=0
2143       do i=iatsc_s,iatsc_e
2144         itypi=iabs(itype(i,1))
2145         if (itypi.eq.ntyp1) cycle
2146         itypi1=iabs(itype(i+1,1))
2147         xi=c(1,nres+i)
2148         yi=c(2,nres+i)
2149         zi=c(3,nres+i)
2150         call to_box(xi,yi,zi)
2151         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2152         dxi=dc_norm(1,nres+i)
2153         dyi=dc_norm(2,nres+i)
2154         dzi=dc_norm(3,nres+i)
2155 !        dsci_inv=dsc_inv(itypi)
2156         dsci_inv=vbld_inv(i+nres)
2157 !
2158 ! Calculate SC interaction energy.
2159 !
2160         do iint=1,nint_gr(i)
2161           do j=istart(i,iint),iend(i,iint)
2162 !el            ind=ind+1
2163             itypj=iabs(itype(j,1))
2164             if (itypj.eq.ntyp1) cycle
2165 !            dscj_inv=dsc_inv(itypj)
2166             dscj_inv=vbld_inv(j+nres)
2167             sig0ij=sigma(itypi,itypj)
2168             r0ij=r0(itypi,itypj)
2169             chi1=chi(itypi,itypj)
2170             chi2=chi(itypj,itypi)
2171             chi12=chi1*chi2
2172             chip1=chip(itypi)
2173             chip2=chip(itypj)
2174             chip12=chip1*chip2
2175             alf1=alp(itypi)
2176             alf2=alp(itypj)
2177             alf12=0.5D0*(alf1+alf2)
2178 ! For diagnostics only!!!
2179 !           chi1=0.0D0
2180 !           chi2=0.0D0
2181 !           chi12=0.0D0
2182 !           chip1=0.0D0
2183 !           chip2=0.0D0
2184 !           chip12=0.0D0
2185 !           alf1=0.0D0
2186 !           alf2=0.0D0
2187 !           alf12=0.0D0
2188             xj=c(1,nres+j)-xi
2189             yj=c(2,nres+j)-yi
2190             zj=c(3,nres+j)-zi
2191            call to_box(xj,yj,zj)
2192            call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2193            aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2194             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2195            bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2196             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2197            xj=boxshift(xj-xi,boxxsize)
2198            yj=boxshift(yj-yi,boxysize)
2199            zj=boxshift(zj-zi,boxzsize)
2200             dxj=dc_norm(1,nres+j)
2201             dyj=dc_norm(2,nres+j)
2202             dzj=dc_norm(3,nres+j)
2203             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2204             rij=dsqrt(rrij)
2205 ! Calculate angle-dependent terms of energy and contributions to their
2206 ! derivatives.
2207             call sc_angular
2208             sigsq=1.0D0/sigsq
2209             sig=sig0ij*dsqrt(sigsq)
2210             rij_shift=1.0D0/rij-sig+r0ij
2211 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2212             if (rij_shift.le.0.0D0) then
2213               evdw=1.0D20
2214               return
2215             endif
2216             sigder=-sig*sigsq
2217 !---------------------------------------------------------------
2218             rij_shift=1.0D0/rij_shift
2219             fac=rij_shift**expon
2220             e1=fac*fac*aa_aq(itypi,itypj)
2221             e2=fac*bb_aq(itypi,itypj)
2222             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2223             eps2der=evdwij*eps3rt
2224             eps3der=evdwij*eps2rt
2225             fac_augm=rrij**expon
2226             e_augm=augm(itypi,itypj)*fac_augm
2227             evdwij=evdwij*eps2rt*eps3rt
2228             evdw=evdw+evdwij+e_augm
2229             if (lprn) then
2230             sigm=dabs(aa_aq(itypi,itypj)/&
2231             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
2232             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
2233             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2234               restyp(itypi,1),i,restyp(itypj,1),j,&
2235               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
2236               chi1,chi2,chip1,chip2,&
2237               eps1,eps2rt**2,eps3rt**2,&
2238               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
2239               evdwij+e_augm
2240             endif
2241 ! Calculate gradient components.
2242             e1=e1*eps1*eps2rt**2*eps3rt**2
2243             fac=-expon*(e1+evdwij)*rij_shift
2244             sigder=fac*sigder
2245             fac=rij*fac-2*expon*rrij*e_augm
2246 ! Calculate the radial part of the gradient
2247             gg(1)=xj*fac
2248             gg(2)=yj*fac
2249             gg(3)=zj*fac
2250 ! Calculate angular part of the gradient.
2251             call sc_grad
2252           enddo      ! j
2253         enddo        ! iint
2254       enddo          ! i
2255       end subroutine egbv
2256 !-----------------------------------------------------------------------------
2257 !el      subroutine sc_angular in module geometry
2258 !-----------------------------------------------------------------------------
2259       subroutine e_softsphere(evdw)
2260 !
2261 ! This subroutine calculates the interaction energy of nonbonded side chains
2262 ! assuming the LJ potential of interaction.
2263 !
2264 !      implicit real*8 (a-h,o-z)
2265 !      include 'DIMENSIONS'
2266       real(kind=8),parameter :: accur=1.0d-10
2267 !      include 'COMMON.GEO'
2268 !      include 'COMMON.VAR'
2269 !      include 'COMMON.LOCAL'
2270 !      include 'COMMON.CHAIN'
2271 !      include 'COMMON.DERIV'
2272 !      include 'COMMON.INTERACT'
2273 !      include 'COMMON.TORSION'
2274 !      include 'COMMON.SBRIDGE'
2275 !      include 'COMMON.NAMES'
2276 !      include 'COMMON.IOUNITS'
2277 !      include 'COMMON.CONTACTS'
2278       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
2279 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2280 !el local variables
2281       integer :: i,iint,j,itypi,itypi1,itypj,k
2282       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
2283       real(kind=8) :: fac
2284
2285       evdw=0.0D0
2286       do i=iatsc_s,iatsc_e
2287         itypi=iabs(itype(i,1))
2288         if (itypi.eq.ntyp1) cycle
2289         itypi1=iabs(itype(i+1,1))
2290         xi=c(1,nres+i)
2291         yi=c(2,nres+i)
2292         zi=c(3,nres+i)
2293         call to_box(xi,yi,zi)
2294
2295 !
2296 ! Calculate SC interaction energy.
2297 !
2298         do iint=1,nint_gr(i)
2299 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2300 !d   &                  'iend=',iend(i,iint)
2301           do j=istart(i,iint),iend(i,iint)
2302             itypj=iabs(itype(j,1))
2303             if (itypj.eq.ntyp1) cycle
2304             xj=boxshift(c(1,nres+j)-xi,boxxsize)
2305             yj=boxshift(c(2,nres+j)-yi,boxysize)
2306             zj=boxshift(c(3,nres+j)-zi,boxzsize)
2307             rij=xj*xj+yj*yj+zj*zj
2308 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2309             r0ij=r0(itypi,itypj)
2310             r0ijsq=r0ij*r0ij
2311 !            print *,i,j,r0ij,dsqrt(rij)
2312             if (rij.lt.r0ijsq) then
2313               evdwij=0.25d0*(rij-r0ijsq)**2
2314               fac=rij-r0ijsq
2315             else
2316               evdwij=0.0d0
2317               fac=0.0d0
2318             endif
2319             evdw=evdw+evdwij
2320 !
2321 ! Calculate the components of the gradient in DC and X
2322 !
2323             gg(1)=xj*fac
2324             gg(2)=yj*fac
2325             gg(3)=zj*fac
2326             do k=1,3
2327               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2328               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2329               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2330               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2331             enddo
2332 !grad            do k=i,j-1
2333 !grad              do l=1,3
2334 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2335 !grad              enddo
2336 !grad            enddo
2337           enddo ! j
2338         enddo ! iint
2339       enddo ! i
2340       return
2341       end subroutine e_softsphere
2342 !-----------------------------------------------------------------------------
2343       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2344 !
2345 ! Soft-sphere potential of p-p interaction
2346 !
2347 !      implicit real*8 (a-h,o-z)
2348 !      include 'DIMENSIONS'
2349 !      include 'COMMON.CONTROL'
2350 !      include 'COMMON.IOUNITS'
2351 !      include 'COMMON.GEO'
2352 !      include 'COMMON.VAR'
2353 !      include 'COMMON.LOCAL'
2354 !      include 'COMMON.CHAIN'
2355 !      include 'COMMON.DERIV'
2356 !      include 'COMMON.INTERACT'
2357 !      include 'COMMON.CONTACTS'
2358 !      include 'COMMON.TORSION'
2359 !      include 'COMMON.VECTORS'
2360 !      include 'COMMON.FFIELD'
2361       real(kind=8),dimension(3) :: ggg
2362 !d      write(iout,*) 'In EELEC_soft_sphere'
2363 !el local variables
2364       integer :: i,j,k,num_conti,iteli,itelj
2365       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2366       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2367       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2368
2369       ees=0.0D0
2370       evdw1=0.0D0
2371       eel_loc=0.0d0
2372       eello_turn3=0.0d0
2373       eello_turn4=0.0d0
2374 !el      ind=0
2375       do i=iatel_s,iatel_e
2376         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2377         dxi=dc(1,i)
2378         dyi=dc(2,i)
2379         dzi=dc(3,i)
2380         xmedi=c(1,i)+0.5d0*dxi
2381         ymedi=c(2,i)+0.5d0*dyi
2382         zmedi=c(3,i)+0.5d0*dzi
2383         call to_box(xmedi,ymedi,zmedi)
2384         num_conti=0
2385 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2386         do j=ielstart(i),ielend(i)
2387           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2388 !el          ind=ind+1
2389           iteli=itel(i)
2390           itelj=itel(j)
2391           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2392           r0ij=rpp(iteli,itelj)
2393           r0ijsq=r0ij*r0ij
2394           dxj=dc(1,j)
2395           dyj=dc(2,j)
2396           dzj=dc(3,j)
2397           xj=c(1,j)+0.5D0*dxj-xmedi
2398           yj=c(2,j)+0.5D0*dyj-ymedi
2399           zj=c(3,j)+0.5D0*dzj-zmedi
2400           call to_box(xj,yj,zj)
2401           xj=boxshift(xj-xmedi,boxxsize)
2402           yj=boxshift(yj-ymedi,boxysize)
2403           zj=boxshift(zj-zmedi,boxzsize)
2404           rij=xj*xj+yj*yj+zj*zj
2405           if (rij.lt.r0ijsq) then
2406             evdw1ij=0.25d0*(rij-r0ijsq)**2
2407             fac=rij-r0ijsq
2408           else
2409             evdw1ij=0.0d0
2410             fac=0.0d0
2411           endif
2412           evdw1=evdw1+evdw1ij
2413 !
2414 ! Calculate contributions to the Cartesian gradient.
2415 !
2416           ggg(1)=fac*xj
2417           ggg(2)=fac*yj
2418           ggg(3)=fac*zj
2419           do k=1,3
2420             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2421             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2422           enddo
2423 !
2424 ! Loop over residues i+1 thru j-1.
2425 !
2426 !grad          do k=i+1,j-1
2427 !grad            do l=1,3
2428 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2429 !grad            enddo
2430 !grad          enddo
2431         enddo ! j
2432       enddo   ! i
2433 !grad      do i=nnt,nct-1
2434 !grad        do k=1,3
2435 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2436 !grad        enddo
2437 !grad        do j=i+1,nct-1
2438 !grad          do k=1,3
2439 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2440 !grad          enddo
2441 !grad        enddo
2442 !grad      enddo
2443       return
2444       end subroutine eelec_soft_sphere
2445 !-----------------------------------------------------------------------------
2446       subroutine vec_and_deriv
2447 !      implicit real*8 (a-h,o-z)
2448 !      include 'DIMENSIONS'
2449 #ifdef MPI
2450       include 'mpif.h'
2451 #endif
2452 !      include 'COMMON.IOUNITS'
2453 !      include 'COMMON.GEO'
2454 !      include 'COMMON.VAR'
2455 !      include 'COMMON.LOCAL'
2456 !      include 'COMMON.CHAIN'
2457 !      include 'COMMON.VECTORS'
2458 !      include 'COMMON.SETUP'
2459 !      include 'COMMON.TIME1'
2460       real(kind=8),dimension(3,3,2) :: uyder,uzder
2461       real(kind=8),dimension(2) :: vbld_inv_temp
2462 ! Compute the local reference systems. For reference system (i), the
2463 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2464 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2465 !el local variables
2466       integer :: i,j,k,l
2467       real(kind=8) :: facy,fac,costh
2468
2469 #ifdef PARVEC
2470       do i=ivec_start,ivec_end
2471 #else
2472       do i=1,nres-1
2473 #endif
2474           if (i.eq.nres-1) then
2475 ! Case of the last full residue
2476 ! Compute the Z-axis
2477             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2478             costh=dcos(pi-theta(nres))
2479             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2480             do k=1,3
2481               uz(k,i)=fac*uz(k,i)
2482             enddo
2483 ! Compute the derivatives of uz
2484             uzder(1,1,1)= 0.0d0
2485             uzder(2,1,1)=-dc_norm(3,i-1)
2486             uzder(3,1,1)= dc_norm(2,i-1)
2487             uzder(1,2,1)= dc_norm(3,i-1)
2488             uzder(2,2,1)= 0.0d0
2489             uzder(3,2,1)=-dc_norm(1,i-1)
2490             uzder(1,3,1)=-dc_norm(2,i-1)
2491             uzder(2,3,1)= dc_norm(1,i-1)
2492             uzder(3,3,1)= 0.0d0
2493             uzder(1,1,2)= 0.0d0
2494             uzder(2,1,2)= dc_norm(3,i)
2495             uzder(3,1,2)=-dc_norm(2,i)
2496             uzder(1,2,2)=-dc_norm(3,i)
2497             uzder(2,2,2)= 0.0d0
2498             uzder(3,2,2)= dc_norm(1,i)
2499             uzder(1,3,2)= dc_norm(2,i)
2500             uzder(2,3,2)=-dc_norm(1,i)
2501             uzder(3,3,2)= 0.0d0
2502 ! Compute the Y-axis
2503             facy=fac
2504             do k=1,3
2505               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2506             enddo
2507 ! Compute the derivatives of uy
2508             do j=1,3
2509               do k=1,3
2510                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2511                               -dc_norm(k,i)*dc_norm(j,i-1)
2512                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2513               enddo
2514               uyder(j,j,1)=uyder(j,j,1)-costh
2515               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2516             enddo
2517             do j=1,2
2518               do k=1,3
2519                 do l=1,3
2520                   uygrad(l,k,j,i)=uyder(l,k,j)
2521                   uzgrad(l,k,j,i)=uzder(l,k,j)
2522                 enddo
2523               enddo
2524             enddo
2525             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2526             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2527             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2528             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2529           else
2530 ! Other residues
2531 ! Compute the Z-axis
2532             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2533             costh=dcos(pi-theta(i+2))
2534             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2535             do k=1,3
2536               uz(k,i)=fac*uz(k,i)
2537             enddo
2538 ! Compute the derivatives of uz
2539             uzder(1,1,1)= 0.0d0
2540             uzder(2,1,1)=-dc_norm(3,i+1)
2541             uzder(3,1,1)= dc_norm(2,i+1)
2542             uzder(1,2,1)= dc_norm(3,i+1)
2543             uzder(2,2,1)= 0.0d0
2544             uzder(3,2,1)=-dc_norm(1,i+1)
2545             uzder(1,3,1)=-dc_norm(2,i+1)
2546             uzder(2,3,1)= dc_norm(1,i+1)
2547             uzder(3,3,1)= 0.0d0
2548             uzder(1,1,2)= 0.0d0
2549             uzder(2,1,2)= dc_norm(3,i)
2550             uzder(3,1,2)=-dc_norm(2,i)
2551             uzder(1,2,2)=-dc_norm(3,i)
2552             uzder(2,2,2)= 0.0d0
2553             uzder(3,2,2)= dc_norm(1,i)
2554             uzder(1,3,2)= dc_norm(2,i)
2555             uzder(2,3,2)=-dc_norm(1,i)
2556             uzder(3,3,2)= 0.0d0
2557 ! Compute the Y-axis
2558             facy=fac
2559             do k=1,3
2560               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2561             enddo
2562 ! Compute the derivatives of uy
2563             do j=1,3
2564               do k=1,3
2565                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2566                               -dc_norm(k,i)*dc_norm(j,i+1)
2567                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2568               enddo
2569               uyder(j,j,1)=uyder(j,j,1)-costh
2570               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2571             enddo
2572             do j=1,2
2573               do k=1,3
2574                 do l=1,3
2575                   uygrad(l,k,j,i)=uyder(l,k,j)
2576                   uzgrad(l,k,j,i)=uzder(l,k,j)
2577                 enddo
2578               enddo
2579             enddo
2580             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2581             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2582             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2583             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2584           endif
2585       enddo
2586       do i=1,nres-1
2587         vbld_inv_temp(1)=vbld_inv(i+1)
2588         if (i.lt.nres-1) then
2589           vbld_inv_temp(2)=vbld_inv(i+2)
2590           else
2591           vbld_inv_temp(2)=vbld_inv(i)
2592           endif
2593         do j=1,2
2594           do k=1,3
2595             do l=1,3
2596               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2597               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2598             enddo
2599           enddo
2600         enddo
2601       enddo
2602 #if defined(PARVEC) && defined(MPI)
2603       if (nfgtasks1.gt.1) then
2604         time00=MPI_Wtime()
2605 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2606 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2607 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2608         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2609          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2610          FG_COMM1,IERR)
2611         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2612          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2613          FG_COMM1,IERR)
2614         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2615          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2616          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2617         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2618          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2619          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2620         time_gather=time_gather+MPI_Wtime()-time00
2621       endif
2622 !      if (fg_rank.eq.0) then
2623 !        write (iout,*) "Arrays UY and UZ"
2624 !        do i=1,nres-1
2625 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2626 !     &     (uz(k,i),k=1,3)
2627 !        enddo
2628 !      endif
2629 #endif
2630       return
2631       end subroutine vec_and_deriv
2632 !-----------------------------------------------------------------------------
2633       subroutine check_vecgrad
2634 !      implicit real*8 (a-h,o-z)
2635 !      include 'DIMENSIONS'
2636 !      include 'COMMON.IOUNITS'
2637 !      include 'COMMON.GEO'
2638 !      include 'COMMON.VAR'
2639 !      include 'COMMON.LOCAL'
2640 !      include 'COMMON.CHAIN'
2641 !      include 'COMMON.VECTORS'
2642       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2643       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2644       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2645       real(kind=8),dimension(3) :: erij
2646       real(kind=8) :: delta=1.0d-7
2647 !el local variables
2648       integer :: i,j,k,l
2649
2650       call vec_and_deriv
2651 !d      do i=1,nres
2652 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2653 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2654 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2655 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2656 !d     &     (dc_norm(if90,i),if90=1,3)
2657 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2658 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2659 !d          write(iout,'(a)')
2660 !d      enddo
2661       do i=1,nres
2662         do j=1,2
2663           do k=1,3
2664             do l=1,3
2665               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2666               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2667             enddo
2668           enddo
2669         enddo
2670       enddo
2671       call vec_and_deriv
2672       do i=1,nres
2673         do j=1,3
2674           uyt(j,i)=uy(j,i)
2675           uzt(j,i)=uz(j,i)
2676         enddo
2677       enddo
2678       do i=1,nres
2679 !d        write (iout,*) 'i=',i
2680         do k=1,3
2681           erij(k)=dc_norm(k,i)
2682         enddo
2683         do j=1,3
2684           do k=1,3
2685             dc_norm(k,i)=erij(k)
2686           enddo
2687           dc_norm(j,i)=dc_norm(j,i)+delta
2688 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2689 !          do k=1,3
2690 !            dc_norm(k,i)=dc_norm(k,i)/fac
2691 !          enddo
2692 !          write (iout,*) (dc_norm(k,i),k=1,3)
2693 !          write (iout,*) (erij(k),k=1,3)
2694           call vec_and_deriv
2695           do k=1,3
2696             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2697             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2698             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2699             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2700           enddo
2701 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2702 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2703 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2704         enddo
2705         do k=1,3
2706           dc_norm(k,i)=erij(k)
2707         enddo
2708 !d        do k=1,3
2709 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2710 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2711 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2712 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2713 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2714 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2715 !d          write (iout,'(a)')
2716 !d        enddo
2717       enddo
2718       return
2719       end subroutine check_vecgrad
2720 !-----------------------------------------------------------------------------
2721       subroutine set_matrices
2722 !      implicit real*8 (a-h,o-z)
2723 !      include 'DIMENSIONS'
2724 #ifdef MPI
2725       include "mpif.h"
2726 !      include "COMMON.SETUP"
2727       integer :: IERR
2728       integer :: status(MPI_STATUS_SIZE)
2729 #endif
2730 !      include 'COMMON.IOUNITS'
2731 !      include 'COMMON.GEO'
2732 !      include 'COMMON.VAR'
2733 !      include 'COMMON.LOCAL'
2734 !      include 'COMMON.CHAIN'
2735 !      include 'COMMON.DERIV'
2736 !      include 'COMMON.INTERACT'
2737 !      include 'COMMON.CONTACTS'
2738 !      include 'COMMON.TORSION'
2739 !      include 'COMMON.VECTORS'
2740 !      include 'COMMON.FFIELD'
2741       real(kind=8) :: auxvec(2),auxmat(2,2)
2742       integer :: i,iti1,iti,k,l
2743       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2,cost1,sint1,&
2744        sint1sq,sint1cub,sint1cost1,b1k,b2k,aux
2745 !       print *,"in set matrices"
2746 !
2747 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2748 ! to calculate the el-loc multibody terms of various order.
2749 !
2750 !AL el      mu=0.0d0
2751
2752 #ifdef PARMAT
2753       do i=ivec_start+2,ivec_end+2
2754 #else
2755       do i=3,nres+1
2756 #endif
2757         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2758           if (itype(i-2,1).eq.0) then
2759           iti = nloctyp
2760           else
2761           iti = itype2loc(itype(i-2,1))
2762           endif
2763         else
2764           iti=nloctyp
2765         endif
2766 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2767         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2768           iti1 = itype2loc(itype(i-1,1))
2769         else
2770           iti1=nloctyp
2771         endif
2772 !        print *,i,itype(i-2,1),iti
2773 #ifdef NEWCORR
2774         cost1=dcos(theta(i-1))
2775         sint1=dsin(theta(i-1))
2776         sint1sq=sint1*sint1
2777         sint1cub=sint1sq*sint1
2778         sint1cost1=2*sint1*cost1
2779 !        print *,"cost1",cost1,theta(i-1)
2780 !c        write (iout,*) "bnew1",i,iti
2781 !c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2782 !c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2783 !c        write (iout,*) "bnew2",i,iti
2784 !c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2785 !c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2786         k=1
2787 !        print *,bnew1(1,k,iti),"bnew1"
2788         do k=1,2
2789           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2790 !          print *,b1k
2791 !          write(*,*) shape(b1)
2792 !          if(.not.allocated(b1)) print *, "WTF?"
2793           b1(k,i-2)=sint1*b1k
2794 !
2795 !             print *,b1(k,i-2)
2796
2797           gtb1(k,i-2)=cost1*b1k-sint1sq*&
2798                    (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2799 !             print *,gtb1(k,i-2)
2800
2801           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2802           b2(k,i-2)=sint1*b2k
2803 !             print *,b2(k,i-2)
2804
2805           gtb2(k,i-2)=cost1*b2k-sint1sq*&
2806                    (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2807 !             print *,gtb2(k,i-2)
2808
2809         enddo
2810 !        print *,b1k,b2k
2811         do k=1,2
2812           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2813           cc(1,k,i-2)=sint1sq*aux
2814           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*&
2815                    (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2816           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2817           dd(1,k,i-2)=sint1sq*aux
2818           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*&
2819                    (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2820         enddo
2821 !        print *,"after cc"
2822         cc(2,1,i-2)=cc(1,2,i-2)
2823         cc(2,2,i-2)=-cc(1,1,i-2)
2824         gtcc(2,1,i-2)=gtcc(1,2,i-2)
2825         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2826         dd(2,1,i-2)=dd(1,2,i-2)
2827         dd(2,2,i-2)=-dd(1,1,i-2)
2828         gtdd(2,1,i-2)=gtdd(1,2,i-2)
2829         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2830 !        print *,"after dd"
2831
2832         do k=1,2
2833           do l=1,2
2834             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2835             EE(l,k,i-2)=sint1sq*aux
2836             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2837           enddo
2838         enddo
2839         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2840         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2841         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2842         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2843         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2844         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2845         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2846 !        print *,"after ee"
2847
2848 !c        b1tilde(1,i-2)=b1(1,i-2)
2849 !c        b1tilde(2,i-2)=-b1(2,i-2)
2850 !c        b2tilde(1,i-2)=b2(1,i-2)
2851 !c        b2tilde(2,i-2)=-b2(2,i-2)
2852 #ifdef DEBUG
2853         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2854         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
2855         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
2856         write (iout,*) 'theta=', theta(i-1)
2857 #endif
2858 #else
2859         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2860 !         write(iout,*) "i,",molnum(i),nloctyp
2861 !         print *, "i,",molnum(i),i,itype(i-2,1)
2862         if (molnum(i).eq.1) then
2863           if (itype(i-2,1).eq.ntyp1) then
2864            iti=nloctyp
2865           else
2866           iti = itype2loc(itype(i-2,1))
2867           endif
2868         else
2869           iti=nloctyp
2870         endif
2871         else
2872           iti=nloctyp
2873         endif
2874 !c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
2875 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2876         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2877           iti1 = itype2loc(itype(i-1,1))
2878         else
2879           iti1=nloctyp
2880         endif
2881 !        print *,i,iti
2882         b1(1,i-2)=b(3,iti)
2883         b1(2,i-2)=b(5,iti)
2884         b2(1,i-2)=b(2,iti)
2885         b2(2,i-2)=b(4,iti)
2886         do k=1,2
2887           do l=1,2
2888            CC(k,l,i-2)=ccold(k,l,iti)
2889            DD(k,l,i-2)=ddold(k,l,iti)
2890            EE(k,l,i-2)=eeold(k,l,iti)
2891           enddo
2892         enddo
2893 #endif
2894         b1tilde(1,i-2)= b1(1,i-2)
2895         b1tilde(2,i-2)=-b1(2,i-2)
2896         b2tilde(1,i-2)= b2(1,i-2)
2897         b2tilde(2,i-2)=-b2(2,i-2)
2898 !c
2899         Ctilde(1,1,i-2)= CC(1,1,i-2)
2900         Ctilde(1,2,i-2)= CC(1,2,i-2)
2901         Ctilde(2,1,i-2)=-CC(2,1,i-2)
2902         Ctilde(2,2,i-2)=-CC(2,2,i-2)
2903 !c
2904         Dtilde(1,1,i-2)= DD(1,1,i-2)
2905         Dtilde(1,2,i-2)= DD(1,2,i-2)
2906         Dtilde(2,1,i-2)=-DD(2,1,i-2)
2907         Dtilde(2,2,i-2)=-DD(2,2,i-2)
2908       enddo
2909 #ifdef PARMAT
2910       do i=ivec_start+2,ivec_end+2
2911 #else
2912       do i=3,nres+1
2913 #endif
2914
2915 !      print *,i,"i"
2916         if (i .lt. nres+1) then
2917           sin1=dsin(phi(i))
2918           cos1=dcos(phi(i))
2919           sintab(i-2)=sin1
2920           costab(i-2)=cos1
2921           obrot(1,i-2)=cos1
2922           obrot(2,i-2)=sin1
2923           sin2=dsin(2*phi(i))
2924           cos2=dcos(2*phi(i))
2925           sintab2(i-2)=sin2
2926           costab2(i-2)=cos2
2927           obrot2(1,i-2)=cos2
2928           obrot2(2,i-2)=sin2
2929           Ug(1,1,i-2)=-cos1
2930           Ug(1,2,i-2)=-sin1
2931           Ug(2,1,i-2)=-sin1
2932           Ug(2,2,i-2)= cos1
2933           Ug2(1,1,i-2)=-cos2
2934           Ug2(1,2,i-2)=-sin2
2935           Ug2(2,1,i-2)=-sin2
2936           Ug2(2,2,i-2)= cos2
2937         else
2938           costab(i-2)=1.0d0
2939           sintab(i-2)=0.0d0
2940           obrot(1,i-2)=1.0d0
2941           obrot(2,i-2)=0.0d0
2942           obrot2(1,i-2)=0.0d0
2943           obrot2(2,i-2)=0.0d0
2944           Ug(1,1,i-2)=1.0d0
2945           Ug(1,2,i-2)=0.0d0
2946           Ug(2,1,i-2)=0.0d0
2947           Ug(2,2,i-2)=1.0d0
2948           Ug2(1,1,i-2)=0.0d0
2949           Ug2(1,2,i-2)=0.0d0
2950           Ug2(2,1,i-2)=0.0d0
2951           Ug2(2,2,i-2)=0.0d0
2952         endif
2953         if (i .gt. 3 .and. i .lt. nres+1) then
2954           obrot_der(1,i-2)=-sin1
2955           obrot_der(2,i-2)= cos1
2956           Ugder(1,1,i-2)= sin1
2957           Ugder(1,2,i-2)=-cos1
2958           Ugder(2,1,i-2)=-cos1
2959           Ugder(2,2,i-2)=-sin1
2960           dwacos2=cos2+cos2
2961           dwasin2=sin2+sin2
2962           obrot2_der(1,i-2)=-dwasin2
2963           obrot2_der(2,i-2)= dwacos2
2964           Ug2der(1,1,i-2)= dwasin2
2965           Ug2der(1,2,i-2)=-dwacos2
2966           Ug2der(2,1,i-2)=-dwacos2
2967           Ug2der(2,2,i-2)=-dwasin2
2968         else
2969           obrot_der(1,i-2)=0.0d0
2970           obrot_der(2,i-2)=0.0d0
2971           Ugder(1,1,i-2)=0.0d0
2972           Ugder(1,2,i-2)=0.0d0
2973           Ugder(2,1,i-2)=0.0d0
2974           Ugder(2,2,i-2)=0.0d0
2975           obrot2_der(1,i-2)=0.0d0
2976           obrot2_der(2,i-2)=0.0d0
2977           Ug2der(1,1,i-2)=0.0d0
2978           Ug2der(1,2,i-2)=0.0d0
2979           Ug2der(2,1,i-2)=0.0d0
2980           Ug2der(2,2,i-2)=0.0d0
2981         endif
2982 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2983         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2984            if (itype(i-2,1).eq.0) then
2985           iti=ntortyp+1
2986            else
2987           iti = itype2loc(itype(i-2,1))
2988            endif
2989         else
2990           iti=nloctyp
2991         endif
2992 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2993         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2994            if (itype(i-1,1).eq.0) then
2995           iti1=nloctyp
2996            else
2997           iti1 = itype2loc(itype(i-1,1))
2998            endif
2999         else
3000           iti1=nloctyp
3001         endif
3002 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
3003 !d        write (iout,*) '*******i',i,' iti1',iti
3004 !        write (iout,*) 'b1',b1(:,iti)
3005 !        write (iout,*) 'b2',b2(:,i-2)
3006 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
3007 !        if (i .gt. iatel_s+2) then
3008         if (i .gt. nnt+2) then
3009           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3010 #ifdef NEWCORR
3011           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3012 !c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3013 #endif
3014
3015           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3016           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3017           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3018           then
3019           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3020           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3021           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3022           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3023           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3024           endif
3025         else
3026           do k=1,2
3027             Ub2(k,i-2)=0.0d0
3028             Ctobr(k,i-2)=0.0d0
3029             Dtobr2(k,i-2)=0.0d0
3030             do l=1,2
3031               EUg(l,k,i-2)=0.0d0
3032               CUg(l,k,i-2)=0.0d0
3033               DUg(l,k,i-2)=0.0d0
3034               DtUg2(l,k,i-2)=0.0d0
3035             enddo
3036           enddo
3037         endif
3038         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3039         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3040         do k=1,2
3041           muder(k,i-2)=Ub2der(k,i-2)
3042         enddo
3043 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3044         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3045           if (itype(i-1,1).eq.0) then
3046            iti1=nloctyp
3047           elseif (itype(i-1,1).le.ntyp) then
3048             iti1 = itype2loc(itype(i-1,1))
3049           else
3050             iti1=nloctyp
3051           endif
3052         else
3053           iti1=nloctyp
3054         endif
3055         do k=1,2
3056           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3057         enddo
3058         if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
3059         if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,i-1)
3060         if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
3061 !d        write (iout,*) 'mu1',mu1(:,i-2)
3062 !d        write (iout,*) 'mu2',mu2(:,i-2)
3063         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3064         then
3065         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3066         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3067         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3068         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3069         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3070 ! Vectors and matrices dependent on a single virtual-bond dihedral.
3071         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3072         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3073         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3074         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3075         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3076         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3077         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3078         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3079         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3080         endif
3081       enddo
3082 ! Matrices dependent on two consecutive virtual-bond dihedrals.
3083 ! The order of matrices is from left to right.
3084       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3085       then
3086 !      do i=max0(ivec_start,2),ivec_end
3087       do i=2,nres-1
3088         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3089         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3090         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3091         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3092         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3093         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3094         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3095         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3096       enddo
3097       endif
3098 #if defined(MPI) && defined(PARMAT)
3099 #ifdef DEBUG
3100 !      if (fg_rank.eq.0) then
3101         write (iout,*) "Arrays UG and UGDER before GATHER"
3102         do i=1,nres-1
3103           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3104            ((ug(l,k,i),l=1,2),k=1,2),&
3105            ((ugder(l,k,i),l=1,2),k=1,2)
3106         enddo
3107         write (iout,*) "Arrays UG2 and UG2DER"
3108         do i=1,nres-1
3109           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3110            ((ug2(l,k,i),l=1,2),k=1,2),&
3111            ((ug2der(l,k,i),l=1,2),k=1,2)
3112         enddo
3113         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3114         do i=1,nres-1
3115           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3116            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3117            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3118         enddo
3119         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3120         do i=1,nres-1
3121           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3122            costab(i),sintab(i),costab2(i),sintab2(i)
3123         enddo
3124         write (iout,*) "Array MUDER"
3125         do i=1,nres-1
3126           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3127         enddo
3128 !      endif
3129 #endif
3130       if (nfgtasks.gt.1) then
3131         time00=MPI_Wtime()
3132 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3133 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3134 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3135 #ifdef MATGATHER
3136         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
3137          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3138          FG_COMM1,IERR)
3139         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
3140          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3141          FG_COMM1,IERR)
3142         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
3143          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3144          FG_COMM1,IERR)
3145         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
3146          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3147          FG_COMM1,IERR)
3148         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
3149          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3150          FG_COMM1,IERR)
3151         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
3152          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3153          FG_COMM1,IERR)
3154         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
3155          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
3156          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3157         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
3158          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
3159          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3160         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
3161          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
3162          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3163         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
3164          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
3165          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3166         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3167         then
3168         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
3169          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3170          FG_COMM1,IERR)
3171         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
3172          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3173          FG_COMM1,IERR)
3174         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
3175          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3176          FG_COMM1,IERR)
3177        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
3178          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3179          FG_COMM1,IERR)
3180         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
3181          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3182          FG_COMM1,IERR)
3183         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
3184          ivec_count(fg_rank1),&
3185          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3186          FG_COMM1,IERR)
3187         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
3188          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3189          FG_COMM1,IERR)
3190         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
3191          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3192          FG_COMM1,IERR)
3193         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
3194          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3195          FG_COMM1,IERR)
3196         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
3197          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3198          FG_COMM1,IERR)
3199         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
3200          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3201          FG_COMM1,IERR)
3202         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
3203          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3204          FG_COMM1,IERR)
3205         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
3206          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3207          FG_COMM1,IERR)
3208         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
3209          ivec_count(fg_rank1),&
3210          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3211          FG_COMM1,IERR)
3212         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
3213          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3214          FG_COMM1,IERR)
3215        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
3216          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3217          FG_COMM1,IERR)
3218         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
3219          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3220          FG_COMM1,IERR)
3221        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
3222          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3223          FG_COMM1,IERR)
3224         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
3225          ivec_count(fg_rank1),&
3226          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3227          FG_COMM1,IERR)
3228         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
3229          ivec_count(fg_rank1),&
3230          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3231          FG_COMM1,IERR)
3232         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
3233          ivec_count(fg_rank1),&
3234          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3235          MPI_MAT2,FG_COMM1,IERR)
3236         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
3237          ivec_count(fg_rank1),&
3238          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3239          MPI_MAT2,FG_COMM1,IERR)
3240         endif
3241 #else
3242 ! Passes matrix info through the ring
3243       isend=fg_rank1
3244       irecv=fg_rank1-1
3245       if (irecv.lt.0) irecv=nfgtasks1-1
3246       iprev=irecv
3247       inext=fg_rank1+1
3248       if (inext.ge.nfgtasks1) inext=0
3249       do i=1,nfgtasks1-1
3250 !        write (iout,*) "isend",isend," irecv",irecv
3251 !        call flush(iout)
3252         lensend=lentyp(isend)
3253         lenrecv=lentyp(irecv)
3254 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3255 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3256 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
3257 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3258 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
3259 !        write (iout,*) "Gather ROTAT1"
3260 !        call flush(iout)
3261 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3262 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
3263 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3264 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
3265 !        write (iout,*) "Gather ROTAT2"
3266 !        call flush(iout)
3267         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
3268          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
3269          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
3270          iprev,4400+irecv,FG_COMM,status,IERR)
3271 !        write (iout,*) "Gather ROTAT_OLD"
3272 !        call flush(iout)
3273         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
3274          MPI_PRECOMP11(lensend),inext,5500+isend,&
3275          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
3276          iprev,5500+irecv,FG_COMM,status,IERR)
3277 !        write (iout,*) "Gather PRECOMP11"
3278 !        call flush(iout)
3279         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
3280          MPI_PRECOMP12(lensend),inext,6600+isend,&
3281          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
3282          iprev,6600+irecv,FG_COMM,status,IERR)
3283 !        write (iout,*) "Gather PRECOMP12"
3284 !        call flush(iout)
3285         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3286         then
3287         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
3288          MPI_ROTAT2(lensend),inext,7700+isend,&
3289          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
3290          iprev,7700+irecv,FG_COMM,status,IERR)
3291 !        write (iout,*) "Gather PRECOMP21"
3292 !        call flush(iout)
3293         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
3294          MPI_PRECOMP22(lensend),inext,8800+isend,&
3295          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
3296          iprev,8800+irecv,FG_COMM,status,IERR)
3297 !        write (iout,*) "Gather PRECOMP22"
3298 !        call flush(iout)
3299         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
3300          MPI_PRECOMP23(lensend),inext,9900+isend,&
3301          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
3302          MPI_PRECOMP23(lenrecv),&
3303          iprev,9900+irecv,FG_COMM,status,IERR)
3304 !        write (iout,*) "Gather PRECOMP23"
3305 !        call flush(iout)
3306         endif
3307         isend=irecv
3308         irecv=irecv-1
3309         if (irecv.lt.0) irecv=nfgtasks1-1
3310       enddo
3311 #endif
3312         time_gather=time_gather+MPI_Wtime()-time00
3313       endif
3314 #ifdef DEBUG
3315 !      if (fg_rank.eq.0) then
3316         write (iout,*) "Arrays UG and UGDER"
3317         do i=1,nres-1
3318           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3319            ((ug(l,k,i),l=1,2),k=1,2),&
3320            ((ugder(l,k,i),l=1,2),k=1,2)
3321         enddo
3322         write (iout,*) "Arrays UG2 and UG2DER"
3323         do i=1,nres-1
3324           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3325            ((ug2(l,k,i),l=1,2),k=1,2),&
3326            ((ug2der(l,k,i),l=1,2),k=1,2)
3327         enddo
3328         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3329         do i=1,nres-1
3330           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3331            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3332            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3333         enddo
3334         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3335         do i=1,nres-1
3336           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3337            costab(i),sintab(i),costab2(i),sintab2(i)
3338         enddo
3339         write (iout,*) "Array MUDER"
3340         do i=1,nres-1
3341           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3342         enddo
3343 !      endif
3344 #endif
3345 #endif
3346 !d      do i=1,nres
3347 !d        iti = itortyp(itype(i,1))
3348 !d        write (iout,*) i
3349 !d        do j=1,2
3350 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3351 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3352 !d        enddo
3353 !d      enddo
3354       return
3355       end subroutine set_matrices
3356 !-----------------------------------------------------------------------------
3357       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3358 !
3359 ! This subroutine calculates the average interaction energy and its gradient
3360 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
3361 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3362 ! The potential depends both on the distance of peptide-group centers and on
3363 ! the orientation of the CA-CA virtual bonds.
3364 !
3365       use comm_locel
3366 !      implicit real*8 (a-h,o-z)
3367 #ifdef MPI
3368       include 'mpif.h'
3369 #endif
3370 !      include 'DIMENSIONS'
3371 !      include 'COMMON.CONTROL'
3372 !      include 'COMMON.SETUP'
3373 !      include 'COMMON.IOUNITS'
3374 !      include 'COMMON.GEO'
3375 !      include 'COMMON.VAR'
3376 !      include 'COMMON.LOCAL'
3377 !      include 'COMMON.CHAIN'
3378 !      include 'COMMON.DERIV'
3379 !      include 'COMMON.INTERACT'
3380 !      include 'COMMON.CONTACTS'
3381 !      include 'COMMON.TORSION'
3382 !      include 'COMMON.VECTORS'
3383 !      include 'COMMON.FFIELD'
3384 !      include 'COMMON.TIME1'
3385       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
3386       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3387       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3388 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3389       real(kind=8),dimension(4) :: muij
3390 !el      integer :: num_conti,j1,j2
3391 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3392 !el        dz_normi,xmedi,ymedi,zmedi
3393
3394 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3395 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3396 !el          num_conti,j1,j2
3397
3398 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3399 #ifdef MOMENT
3400       real(kind=8) :: scal_el=1.0d0
3401 #else
3402       real(kind=8) :: scal_el=0.5d0
3403 #endif
3404 ! 12/13/98
3405 ! 13-go grudnia roku pamietnego...
3406       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3407                                              0.0d0,1.0d0,0.0d0,&
3408                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3409 !el local variables
3410       integer :: i,k,j,icont
3411       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
3412       real(kind=8) :: fac,t_eelecij,fracinbuf
3413
3414
3415 !d      write(iout,*) 'In EELEC'
3416 !        print *,"IN EELEC"
3417 !d      do i=1,nloctyp
3418 !d        write(iout,*) 'Type',i
3419 !d        write(iout,*) 'B1',B1(:,i)
3420 !d        write(iout,*) 'B2',B2(:,i)
3421 !d        write(iout,*) 'CC',CC(:,:,i)
3422 !d        write(iout,*) 'DD',DD(:,:,i)
3423 !d        write(iout,*) 'EE',EE(:,:,i)
3424 !d      enddo
3425 !d      call check_vecgrad
3426 !d      stop
3427 !      ees=0.0d0  !AS
3428 !      evdw1=0.0d0
3429 !      eel_loc=0.0d0
3430 !      eello_turn3=0.0d0
3431 !      eello_turn4=0.0d0
3432       t_eelecij=0.0d0
3433       ees=0.0D0
3434       evdw1=0.0D0
3435       eel_loc=0.0d0
3436       eello_turn3=0.0d0
3437       eello_turn4=0.0d0
3438 !
3439
3440       if (icheckgrad.eq.1) then
3441 !el
3442 !        do i=0,2*nres+2
3443 !          dc_norm(1,i)=0.0d0
3444 !          dc_norm(2,i)=0.0d0
3445 !          dc_norm(3,i)=0.0d0
3446 !        enddo
3447         do i=1,nres-1
3448           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3449           do k=1,3
3450             dc_norm(k,i)=dc(k,i)*fac
3451           enddo
3452 !          write (iout,*) 'i',i,' fac',fac
3453         enddo
3454       endif
3455 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3456 !        wturn6
3457       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3458           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3459           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3460 !        call vec_and_deriv
3461 #ifdef TIMING
3462         time01=MPI_Wtime()
3463 #endif
3464 !        print *, "before set matrices"
3465         call set_matrices
3466 !        print *, "after set matrices"
3467
3468 #ifdef TIMING
3469         time_mat=time_mat+MPI_Wtime()-time01
3470 #endif
3471       endif
3472 !       print *, "after set matrices"
3473 !d      do i=1,nres-1
3474 !d        write (iout,*) 'i=',i
3475 !d        do k=1,3
3476 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3477 !d        enddo
3478 !d        do k=1,3
3479 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3480 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3481 !d        enddo
3482 !d      enddo
3483       t_eelecij=0.0d0
3484       ees=0.0D0
3485       evdw1=0.0D0
3486       eel_loc=0.0d0
3487       eello_turn3=0.0d0
3488       eello_turn4=0.0d0
3489 !el      ind=0
3490       do i=1,nres
3491         num_cont_hb(i)=0
3492       enddo
3493 !d      print '(a)','Enter EELEC'
3494 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3495 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3496 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3497       do i=1,nres
3498         gel_loc_loc(i)=0.0d0
3499         gcorr_loc(i)=0.0d0
3500       enddo
3501 !
3502 !
3503 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3504 !
3505 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3506 !
3507
3508
3509 !        print *,"before iturn3 loop"
3510       do i=iturn3_start,iturn3_end
3511         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3512         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3513         dxi=dc(1,i)
3514         dyi=dc(2,i)
3515         dzi=dc(3,i)
3516         dx_normi=dc_norm(1,i)
3517         dy_normi=dc_norm(2,i)
3518         dz_normi=dc_norm(3,i)
3519         xmedi=c(1,i)+0.5d0*dxi
3520         ymedi=c(2,i)+0.5d0*dyi
3521         zmedi=c(3,i)+0.5d0*dzi
3522         call to_box(xmedi,ymedi,zmedi)
3523         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3524         num_conti=0
3525        call eelecij(i,i+2,ees,evdw1,eel_loc)
3526         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3527         num_cont_hb(i)=num_conti
3528       enddo
3529       do i=iturn4_start,iturn4_end
3530         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3531           .or. itype(i+3,1).eq.ntyp1 &
3532           .or. itype(i+4,1).eq.ntyp1) cycle
3533 !        print *,"before2",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3534         dxi=dc(1,i)
3535         dyi=dc(2,i)
3536         dzi=dc(3,i)
3537         dx_normi=dc_norm(1,i)
3538         dy_normi=dc_norm(2,i)
3539         dz_normi=dc_norm(3,i)
3540         xmedi=c(1,i)+0.5d0*dxi
3541         ymedi=c(2,i)+0.5d0*dyi
3542         zmedi=c(3,i)+0.5d0*dzi
3543         call to_box(xmedi,ymedi,zmedi)
3544         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3545         num_conti=num_cont_hb(i)
3546         call eelecij(i,i+3,ees,evdw1,eel_loc)
3547         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3548         call eturn4(i,eello_turn4)
3549 !        print *,"before",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3550         num_cont_hb(i)=num_conti
3551       enddo   ! i
3552 !
3553 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3554 !
3555 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3556 !      do i=iatel_s,iatel_e
3557 ! JPRDLC
3558        do icont=g_listpp_start,g_listpp_end
3559         i=newcontlistppi(icont)
3560         j=newcontlistppj(icont)
3561         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3562         dxi=dc(1,i)
3563         dyi=dc(2,i)
3564         dzi=dc(3,i)
3565         dx_normi=dc_norm(1,i)
3566         dy_normi=dc_norm(2,i)
3567         dz_normi=dc_norm(3,i)
3568         xmedi=c(1,i)+0.5d0*dxi
3569         ymedi=c(2,i)+0.5d0*dyi
3570         zmedi=c(3,i)+0.5d0*dzi
3571         call to_box(xmedi,ymedi,zmedi)
3572         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3573
3574 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3575         num_conti=num_cont_hb(i)
3576 !        do j=ielstart(i),ielend(i)
3577 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3578           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3579           call eelecij(i,j,ees,evdw1,eel_loc)
3580 !        enddo ! j
3581         num_cont_hb(i)=num_conti
3582       enddo   ! i
3583 !      write (iout,*) "Number of loop steps in EELEC:",ind
3584 !d      do i=1,nres
3585 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3586 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3587 !d      enddo
3588 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3589 !cc      eel_loc=eel_loc+eello_turn3
3590 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3591       return
3592       end subroutine eelec
3593 !-----------------------------------------------------------------------------
3594       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3595
3596       use comm_locel
3597 !      implicit real*8 (a-h,o-z)
3598 !      include 'DIMENSIONS'
3599 #ifdef MPI
3600       include "mpif.h"
3601 #endif
3602 !      include 'COMMON.CONTROL'
3603 !      include 'COMMON.IOUNITS'
3604 !      include 'COMMON.GEO'
3605 !      include 'COMMON.VAR'
3606 !      include 'COMMON.LOCAL'
3607 !      include 'COMMON.CHAIN'
3608 !      include 'COMMON.DERIV'
3609 !      include 'COMMON.INTERACT'
3610 !      include 'COMMON.CONTACTS'
3611 !      include 'COMMON.TORSION'
3612 !      include 'COMMON.VECTORS'
3613 !      include 'COMMON.FFIELD'
3614 !      include 'COMMON.TIME1'
3615       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3616       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3617       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3618 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3619       real(kind=8),dimension(4) :: muij
3620       real(kind=8) :: geel_loc_ij,geel_loc_ji
3621       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3622                     dist_temp, dist_init,rlocshield,fracinbuf
3623       integer xshift,yshift,zshift,ilist,iresshield
3624 !el      integer :: num_conti,j1,j2
3625 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3626 !el        dz_normi,xmedi,ymedi,zmedi
3627
3628 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3629 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3630 !el          num_conti,j1,j2
3631
3632 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3633 #ifdef MOMENT
3634       real(kind=8) :: scal_el=1.0d0
3635 #else
3636       real(kind=8) :: scal_el=0.5d0
3637 #endif
3638 ! 12/13/98
3639 ! 13-go grudnia roku pamietnego...
3640       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3641                                              0.0d0,1.0d0,0.0d0,&
3642                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3643 !      integer :: maxconts=nres/4
3644 !el local variables
3645       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3646       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3647       real(kind=8) ::  faclipij2, faclipij
3648       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3649       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3650                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3651                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3652                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3653                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3654                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3655                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3656                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3657 !      maxconts=nres/4
3658 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3659 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3660
3661 !          time00=MPI_Wtime()
3662 !d      write (iout,*) "eelecij",i,j
3663 !          ind=ind+1
3664           iteli=itel(i)
3665           itelj=itel(j)
3666           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3667           aaa=app(iteli,itelj)
3668           bbb=bpp(iteli,itelj)
3669           ael6i=ael6(iteli,itelj)
3670           ael3i=ael3(iteli,itelj)
3671           dxj=dc(1,j)
3672           dyj=dc(2,j)
3673           dzj=dc(3,j)
3674           dx_normj=dc_norm(1,j)
3675           dy_normj=dc_norm(2,j)
3676           dz_normj=dc_norm(3,j)
3677 !          xj=c(1,j)+0.5D0*dxj-xmedi
3678 !          yj=c(2,j)+0.5D0*dyj-ymedi
3679 !          zj=c(3,j)+0.5D0*dzj-zmedi
3680           xj=c(1,j)+0.5D0*dxj
3681           yj=c(2,j)+0.5D0*dyj
3682           zj=c(3,j)+0.5D0*dzj
3683
3684           call to_box(xj,yj,zj)
3685           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
3686           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
3687           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3688           xj=boxshift(xj-xmedi,boxxsize)
3689           yj=boxshift(yj-ymedi,boxysize)
3690           zj=boxshift(zj-zmedi,boxzsize)
3691
3692           rij=xj*xj+yj*yj+zj*zj
3693           rrmij=1.0D0/rij
3694           rij=dsqrt(rij)
3695 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3696             sss_ele_cut=sscale_ele(rij)
3697             sss_ele_grad=sscagrad_ele(rij)
3698 !             sss_ele_cut=1.0d0
3699 !             sss_ele_grad=0.0d0
3700 !            print *,sss_ele_cut,sss_ele_grad,&
3701 !            (rij),r_cut_ele,rlamb_ele
3702             if (sss_ele_cut.le.0.0) go to 128
3703
3704           rmij=1.0D0/rij
3705           r3ij=rrmij*rmij
3706           r6ij=r3ij*r3ij
3707           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3708           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3709           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3710           fac=cosa-3.0D0*cosb*cosg
3711           ev1=aaa*r6ij*r6ij
3712 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3713           if (j.eq.i+2) ev1=scal_el*ev1
3714           ev2=bbb*r6ij
3715           fac3=ael6i*r6ij
3716           fac4=ael3i*r3ij
3717           evdwij=ev1+ev2
3718           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3719           el2=fac4*fac
3720 !          eesij=el1+el2
3721           if (shield_mode.gt.0) then
3722 !C          fac_shield(i)=0.4
3723 !C          fac_shield(j)=0.6
3724           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3725           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3726           eesij=(el1+el2)
3727           ees=ees+eesij*sss_ele_cut
3728 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3729 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3730           else
3731           fac_shield(i)=1.0
3732           fac_shield(j)=1.0
3733           eesij=(el1+el2)
3734           ees=ees+eesij   &
3735             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3736 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3737           endif
3738
3739 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3740           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3741 !          ees=ees+eesij*sss_ele_cut
3742           evdw1=evdw1+evdwij*sss_ele_cut  &
3743            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3744 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3745 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3746 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3747 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3748
3749           if (energy_dec) then
3750 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3751 !                  'evdw1',i,j,evdwij,&
3752 !                  iteli,itelj,aaa,evdw1
3753               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3754               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3755           endif
3756 !
3757 ! Calculate contributions to the Cartesian gradient.
3758 !
3759 #ifdef SPLITELE
3760           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3761               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3762           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3763              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3764           fac1=fac
3765           erij(1)=xj*rmij
3766           erij(2)=yj*rmij
3767           erij(3)=zj*rmij
3768 !
3769 ! Radial derivatives. First process both termini of the fragment (i,j)
3770 !
3771           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3772           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3773           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3774            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3775           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3776             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3777
3778           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3779           (shield_mode.gt.0)) then
3780 !C          print *,i,j
3781           do ilist=1,ishield_list(i)
3782            iresshield=shield_list(ilist,i)
3783            do k=1,3
3784            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3785            *2.0*sss_ele_cut
3786            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3787                    rlocshield &
3788             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3789             *sss_ele_cut
3790             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3791            enddo
3792           enddo
3793           do ilist=1,ishield_list(j)
3794            iresshield=shield_list(ilist,j)
3795            do k=1,3
3796            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3797           *2.0*sss_ele_cut
3798            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3799                    rlocshield &
3800            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3801            *sss_ele_cut
3802            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3803            enddo
3804           enddo
3805           do k=1,3
3806             gshieldc(k,i)=gshieldc(k,i)+ &
3807                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3808            *sss_ele_cut
3809
3810             gshieldc(k,j)=gshieldc(k,j)+ &
3811                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3812            *sss_ele_cut
3813
3814             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3815                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3816            *sss_ele_cut
3817
3818             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3819                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3820            *sss_ele_cut
3821
3822            enddo
3823            endif
3824
3825
3826 !          do k=1,3
3827 !            ghalf=0.5D0*ggg(k)
3828 !            gelc(k,i)=gelc(k,i)+ghalf
3829 !            gelc(k,j)=gelc(k,j)+ghalf
3830 !          enddo
3831 ! 9/28/08 AL Gradient compotents will be summed only at the end
3832           do k=1,3
3833             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3834             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3835           enddo
3836             gelc_long(3,j)=gelc_long(3,j)+  &
3837           ssgradlipj*eesij/2.0d0*lipscale**2&
3838            *sss_ele_cut
3839
3840             gelc_long(3,i)=gelc_long(3,i)+  &
3841           ssgradlipi*eesij/2.0d0*lipscale**2&
3842            *sss_ele_cut
3843
3844
3845 !
3846 ! Loop over residues i+1 thru j-1.
3847 !
3848 !grad          do k=i+1,j-1
3849 !grad            do l=1,3
3850 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3851 !grad            enddo
3852 !grad          enddo
3853           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3854            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3855           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3856            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3857           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3858            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3859
3860 !          do k=1,3
3861 !            ghalf=0.5D0*ggg(k)
3862 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3863 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3864 !          enddo
3865 ! 9/28/08 AL Gradient compotents will be summed only at the end
3866           do k=1,3
3867             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3868             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3869           enddo
3870
3871 !C Lipidic part for scaling weight
3872            gvdwpp(3,j)=gvdwpp(3,j)+ &
3873           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3874            gvdwpp(3,i)=gvdwpp(3,i)+ &
3875           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3876 !! Loop over residues i+1 thru j-1.
3877 !
3878 !grad          do k=i+1,j-1
3879 !grad            do l=1,3
3880 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3881 !grad            enddo
3882 !grad          enddo
3883 #else
3884           facvdw=(ev1+evdwij)*sss_ele_cut &
3885            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3886
3887           facel=(el1+eesij)*sss_ele_cut
3888           fac1=fac
3889           fac=-3*rrmij*(facvdw+facvdw+facel)
3890           erij(1)=xj*rmij
3891           erij(2)=yj*rmij
3892           erij(3)=zj*rmij
3893 !
3894 ! Radial derivatives. First process both termini of the fragment (i,j)
3895 !
3896           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3897           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3898           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3899 !          do k=1,3
3900 !            ghalf=0.5D0*ggg(k)
3901 !            gelc(k,i)=gelc(k,i)+ghalf
3902 !            gelc(k,j)=gelc(k,j)+ghalf
3903 !          enddo
3904 ! 9/28/08 AL Gradient compotents will be summed only at the end
3905           do k=1,3
3906             gelc_long(k,j)=gelc(k,j)+ggg(k)
3907             gelc_long(k,i)=gelc(k,i)-ggg(k)
3908           enddo
3909 !
3910 ! Loop over residues i+1 thru j-1.
3911 !
3912 !grad          do k=i+1,j-1
3913 !grad            do l=1,3
3914 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3915 !grad            enddo
3916 !grad          enddo
3917 ! 9/28/08 AL Gradient compotents will be summed only at the end
3918           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3919            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3920           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3921            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3922           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3923            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3924
3925           do k=1,3
3926             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3927             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3928           enddo
3929            gvdwpp(3,j)=gvdwpp(3,j)+ &
3930           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3931            gvdwpp(3,i)=gvdwpp(3,i)+ &
3932           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3933
3934 #endif
3935 !
3936 ! Angular part
3937 !
3938           ecosa=2.0D0*fac3*fac1+fac4
3939           fac4=-3.0D0*fac4
3940           fac3=-6.0D0*fac3
3941           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3942           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3943           do k=1,3
3944             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3945             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3946           enddo
3947 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3948 !d   &          (dcosg(k),k=1,3)
3949           do k=1,3
3950             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3951              *fac_shield(i)**2*fac_shield(j)**2 &
3952              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3953
3954           enddo
3955 !          do k=1,3
3956 !            ghalf=0.5D0*ggg(k)
3957 !            gelc(k,i)=gelc(k,i)+ghalf
3958 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3959 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3960 !            gelc(k,j)=gelc(k,j)+ghalf
3961 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3962 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3963 !          enddo
3964 !grad          do k=i+1,j-1
3965 !grad            do l=1,3
3966 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3967 !grad            enddo
3968 !grad          enddo
3969           do k=1,3
3970             gelc(k,i)=gelc(k,i) &
3971                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3972                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3973                      *sss_ele_cut &
3974                      *fac_shield(i)**2*fac_shield(j)**2 &
3975                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3976
3977             gelc(k,j)=gelc(k,j) &
3978                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3979                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3980                      *sss_ele_cut  &
3981                      *fac_shield(i)**2*fac_shield(j)**2  &
3982                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3983
3984             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3985             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3986           enddo
3987
3988           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3989               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3990               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3991 !
3992 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3993 !   energy of a peptide unit is assumed in the form of a second-order
3994 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3995 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3996 !   are computed for EVERY pair of non-contiguous peptide groups.
3997 !
3998           if (j.lt.nres-1) then
3999             j1=j+1
4000             j2=j-1
4001           else
4002             j1=j-1
4003             j2=j-2
4004           endif
4005           kkk=0
4006           do k=1,2
4007             do l=1,2
4008               kkk=kkk+1
4009               muij(kkk)=mu(k,i)*mu(l,j)
4010 #ifdef NEWCORR
4011              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4012 !c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4013              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4014              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4015 !c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4016              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4017 #endif
4018
4019             enddo
4020           enddo
4021 !d         write (iout,*) 'EELEC: i',i,' j',j
4022 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
4023 !d          write(iout,*) 'muij',muij
4024           ury=scalar(uy(1,i),erij)
4025           urz=scalar(uz(1,i),erij)
4026           vry=scalar(uy(1,j),erij)
4027           vrz=scalar(uz(1,j),erij)
4028           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4029           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4030           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4031           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4032           fac=dsqrt(-ael6i)*r3ij
4033           a22=a22*fac
4034           a23=a23*fac
4035           a32=a32*fac
4036           a33=a33*fac
4037 !d          write (iout,'(4i5,4f10.5)')
4038 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
4039 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4040 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4041 !d     &      uy(:,j),uz(:,j)
4042 !d          write (iout,'(4f10.5)')
4043 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4044 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4045 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
4046 !d           write (iout,'(9f10.5/)')
4047 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4048 ! Derivatives of the elements of A in virtual-bond vectors
4049           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4050           do k=1,3
4051             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4052             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4053             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4054             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4055             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4056             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4057             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4058             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4059             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4060             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4061             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4062             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4063           enddo
4064 ! Compute radial contributions to the gradient
4065           facr=-3.0d0*rrmij
4066           a22der=a22*facr
4067           a23der=a23*facr
4068           a32der=a32*facr
4069           a33der=a33*facr
4070           agg(1,1)=a22der*xj
4071           agg(2,1)=a22der*yj
4072           agg(3,1)=a22der*zj
4073           agg(1,2)=a23der*xj
4074           agg(2,2)=a23der*yj
4075           agg(3,2)=a23der*zj
4076           agg(1,3)=a32der*xj
4077           agg(2,3)=a32der*yj
4078           agg(3,3)=a32der*zj
4079           agg(1,4)=a33der*xj
4080           agg(2,4)=a33der*yj
4081           agg(3,4)=a33der*zj
4082 ! Add the contributions coming from er
4083           fac3=-3.0d0*fac
4084           do k=1,3
4085             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4086             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4087             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4088             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4089           enddo
4090           do k=1,3
4091 ! Derivatives in DC(i)
4092 !grad            ghalf1=0.5d0*agg(k,1)
4093 !grad            ghalf2=0.5d0*agg(k,2)
4094 !grad            ghalf3=0.5d0*agg(k,3)
4095 !grad            ghalf4=0.5d0*agg(k,4)
4096             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
4097             -3.0d0*uryg(k,2)*vry)!+ghalf1
4098             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
4099             -3.0d0*uryg(k,2)*vrz)!+ghalf2
4100             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
4101             -3.0d0*urzg(k,2)*vry)!+ghalf3
4102             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
4103             -3.0d0*urzg(k,2)*vrz)!+ghalf4
4104 ! Derivatives in DC(i+1)
4105             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
4106             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4107             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
4108             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4109             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
4110             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4111             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
4112             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4113 ! Derivatives in DC(j)
4114             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
4115             -3.0d0*vryg(k,2)*ury)!+ghalf1
4116             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
4117             -3.0d0*vrzg(k,2)*ury)!+ghalf2
4118             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
4119             -3.0d0*vryg(k,2)*urz)!+ghalf3
4120             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
4121             -3.0d0*vrzg(k,2)*urz)!+ghalf4
4122 ! Derivatives in DC(j+1) or DC(nres-1)
4123             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
4124             -3.0d0*vryg(k,3)*ury)
4125             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
4126             -3.0d0*vrzg(k,3)*ury)
4127             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
4128             -3.0d0*vryg(k,3)*urz)
4129             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
4130             -3.0d0*vrzg(k,3)*urz)
4131 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
4132 !grad              do l=1,4
4133 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4134 !grad              enddo
4135 !grad            endif
4136           enddo
4137           acipa(1,1)=a22
4138           acipa(1,2)=a23
4139           acipa(2,1)=a32
4140           acipa(2,2)=a33
4141           a22=-a22
4142           a23=-a23
4143           do l=1,2
4144             do k=1,3
4145               agg(k,l)=-agg(k,l)
4146               aggi(k,l)=-aggi(k,l)
4147               aggi1(k,l)=-aggi1(k,l)
4148               aggj(k,l)=-aggj(k,l)
4149               aggj1(k,l)=-aggj1(k,l)
4150             enddo
4151           enddo
4152           if (j.lt.nres-1) then
4153             a22=-a22
4154             a32=-a32
4155             do l=1,3,2
4156               do k=1,3
4157                 agg(k,l)=-agg(k,l)
4158                 aggi(k,l)=-aggi(k,l)
4159                 aggi1(k,l)=-aggi1(k,l)
4160                 aggj(k,l)=-aggj(k,l)
4161                 aggj1(k,l)=-aggj1(k,l)
4162               enddo
4163             enddo
4164           else
4165             a22=-a22
4166             a23=-a23
4167             a32=-a32
4168             a33=-a33
4169             do l=1,4
4170               do k=1,3
4171                 agg(k,l)=-agg(k,l)
4172                 aggi(k,l)=-aggi(k,l)
4173                 aggi1(k,l)=-aggi1(k,l)
4174                 aggj(k,l)=-aggj(k,l)
4175                 aggj1(k,l)=-aggj1(k,l)
4176               enddo
4177             enddo
4178           endif
4179           ENDIF ! WCORR
4180           IF (wel_loc.gt.0.0d0) THEN
4181 ! Contribution to the local-electrostatic energy coming from the i-j pair
4182           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
4183            +a33*muij(4)
4184           if (shield_mode.eq.0) then
4185            fac_shield(i)=1.0
4186            fac_shield(j)=1.0
4187           endif
4188           eel_loc_ij=eel_loc_ij &
4189          *fac_shield(i)*fac_shield(j) &
4190          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4191 !C Now derivative over eel_loc
4192           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
4193          (shield_mode.gt.0)) then
4194 !C          print *,i,j
4195
4196           do ilist=1,ishield_list(i)
4197            iresshield=shield_list(ilist,i)
4198            do k=1,3
4199            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
4200                                                 /fac_shield(i)&
4201            *sss_ele_cut
4202            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4203                    rlocshield  &
4204           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
4205           *sss_ele_cut
4206
4207             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4208            +rlocshield
4209            enddo
4210           enddo
4211           do ilist=1,ishield_list(j)
4212            iresshield=shield_list(ilist,j)
4213            do k=1,3
4214            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
4215                                             /fac_shield(j)   &
4216             *sss_ele_cut
4217            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4218                    rlocshield  &
4219       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
4220        *sss_ele_cut
4221
4222            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4223                   +rlocshield
4224
4225            enddo
4226           enddo
4227
4228           do k=1,3
4229             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
4230                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4231                     *sss_ele_cut
4232             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
4233                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4234                     *sss_ele_cut
4235             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
4236                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4237                     *sss_ele_cut
4238             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
4239                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4240                     *sss_ele_cut
4241
4242            enddo
4243            endif
4244
4245 #ifdef NEWCORR
4246          geel_loc_ij=(a22*gmuij1(1)&
4247           +a23*gmuij1(2)&
4248           +a32*gmuij1(3)&
4249           +a33*gmuij1(4))&
4250          *fac_shield(i)*fac_shield(j)&
4251                     *sss_ele_cut     &
4252          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4253
4254
4255 !c         write(iout,*) "derivative over thatai"
4256 !c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4257 !c     &   a33*gmuij1(4)
4258          gloc(nphi+i,icg)=gloc(nphi+i,icg)+&
4259            geel_loc_ij*wel_loc
4260 !c         write(iout,*) "derivative over thatai-1"
4261 !c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4262 !c     &   a33*gmuij2(4)
4263          geel_loc_ij=&
4264           a22*gmuij2(1)&
4265           +a23*gmuij2(2)&
4266           +a32*gmuij2(3)&
4267           +a33*gmuij2(4)
4268          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+&
4269            geel_loc_ij*wel_loc&
4270          *fac_shield(i)*fac_shield(j)&
4271                     *sss_ele_cut &
4272          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4273
4274
4275 !c  Derivative over j residue
4276          geel_loc_ji=a22*gmuji1(1)&
4277           +a23*gmuji1(2)&
4278           +a32*gmuji1(3)&
4279           +a33*gmuji1(4)
4280 !c         write(iout,*) "derivative over thataj"
4281 !c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4282 !c     &   a33*gmuji1(4)
4283
4284         gloc(nphi+j,icg)=gloc(nphi+j,icg)+&
4285            geel_loc_ji*wel_loc&
4286          *fac_shield(i)*fac_shield(j)&
4287                     *sss_ele_cut &
4288          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4289
4290
4291          geel_loc_ji=&
4292           +a22*gmuji2(1)&
4293           +a23*gmuji2(2)&
4294           +a32*gmuji2(3)&
4295           +a33*gmuji2(4)
4296 !c         write(iout,*) "derivative over thataj-1"
4297 !c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4298 !c     &   a33*gmuji2(4)
4299          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+&
4300            geel_loc_ji*wel_loc&
4301          *fac_shield(i)*fac_shield(j)&
4302                     *sss_ele_cut &
4303          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4304
4305 #endif
4306
4307 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4308 !           eel_loc_ij=0.0
4309 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4310 !                  'eelloc',i,j,eel_loc_ij
4311           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,8f8.3)') &
4312                   'eelloc',i,j,eel_loc_ij,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4313 !           print *,"EELLOC",i,gel_loc_loc(i-1)
4314
4315 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4316 !          if (energy_dec) write (iout,*) "muij",muij
4317 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
4318
4319           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
4320 ! Partial derivatives in virtual-bond dihedral angles gamma
4321           if (i.gt.1) &
4322           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
4323                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
4324                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
4325                  *sss_ele_cut  &
4326           *fac_shield(i)*fac_shield(j) &
4327           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4328
4329           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
4330                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
4331                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
4332                  *sss_ele_cut &
4333           *fac_shield(i)*fac_shield(j) &
4334           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4335 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4336 !          do l=1,3
4337 !            ggg(1)=(agg(1,1)*muij(1)+ &
4338 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
4339 !            *sss_ele_cut &
4340 !             +eel_loc_ij*sss_ele_grad*rmij*xj
4341 !            ggg(2)=(agg(2,1)*muij(1)+ &
4342 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
4343 !            *sss_ele_cut &
4344 !             +eel_loc_ij*sss_ele_grad*rmij*yj
4345 !            ggg(3)=(agg(3,1)*muij(1)+ &
4346 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
4347 !            *sss_ele_cut &
4348 !             +eel_loc_ij*sss_ele_grad*rmij*zj
4349            xtemp(1)=xj
4350            xtemp(2)=yj
4351            xtemp(3)=zj
4352
4353            do l=1,3
4354             ggg(l)=(agg(l,1)*muij(1)+ &
4355                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
4356             *sss_ele_cut &
4357           *fac_shield(i)*fac_shield(j) &
4358           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
4359              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4360
4361
4362             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4363             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4364 !grad            ghalf=0.5d0*ggg(l)
4365 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4366 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4367           enddo
4368             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
4369           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
4370           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4371
4372             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
4373           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
4374           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4375
4376 !grad          do k=i+1,j2
4377 !grad            do l=1,3
4378 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4379 !grad            enddo
4380 !grad          enddo
4381 ! Remaining derivatives of eello
4382           do l=1,3
4383             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4384                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
4385             *sss_ele_cut &
4386           *fac_shield(i)*fac_shield(j) &
4387           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4388
4389 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4390             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4391                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4392             +aggi1(l,4)*muij(4))&
4393             *sss_ele_cut &
4394           *fac_shield(i)*fac_shield(j) &
4395           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4396
4397 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4398             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4399                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4400             *sss_ele_cut &
4401           *fac_shield(i)*fac_shield(j) &
4402           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4403
4404 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4405             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4406                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4407             +aggj1(l,4)*muij(4))&
4408             *sss_ele_cut &
4409           *fac_shield(i)*fac_shield(j) &
4410          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4411
4412 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4413           enddo
4414           ENDIF
4415 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4416 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4417           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4418              .and. num_conti.le.maxconts) then
4419 !            write (iout,*) i,j," entered corr"
4420 !
4421 ! Calculate the contact function. The ith column of the array JCONT will
4422 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4423 ! greater than I). The arrays FACONT and GACONT will contain the values of
4424 ! the contact function and its derivative.
4425 !           r0ij=1.02D0*rpp(iteli,itelj)
4426 !           r0ij=1.11D0*rpp(iteli,itelj)
4427             r0ij=2.20D0*rpp(iteli,itelj)
4428 !           r0ij=1.55D0*rpp(iteli,itelj)
4429             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4430 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4431             if (fcont.gt.0.0D0) then
4432               num_conti=num_conti+1
4433               if (num_conti.gt.maxconts) then
4434 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4435 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4436                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4437                                ' will skip next contacts for this conf.', num_conti
4438               else
4439                 jcont_hb(num_conti,i)=j
4440 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4441 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4442                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4443                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4444 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4445 !  terms.
4446                 d_cont(num_conti,i)=rij
4447 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4448 !     --- Electrostatic-interaction matrix ---
4449                 a_chuj(1,1,num_conti,i)=a22
4450                 a_chuj(1,2,num_conti,i)=a23
4451                 a_chuj(2,1,num_conti,i)=a32
4452                 a_chuj(2,2,num_conti,i)=a33
4453 !     --- Gradient of rij
4454                 do kkk=1,3
4455                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4456                 enddo
4457                 kkll=0
4458                 do k=1,2
4459                   do l=1,2
4460                     kkll=kkll+1
4461                     do m=1,3
4462                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4463                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4464                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4465                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4466                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4467                     enddo
4468                   enddo
4469                 enddo
4470                 ENDIF
4471                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4472 ! Calculate contact energies
4473                 cosa4=4.0D0*cosa
4474                 wij=cosa-3.0D0*cosb*cosg
4475                 cosbg1=cosb+cosg
4476                 cosbg2=cosb-cosg
4477 !               fac3=dsqrt(-ael6i)/r0ij**3
4478                 fac3=dsqrt(-ael6i)*r3ij
4479 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4480                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4481                 if (ees0tmp.gt.0) then
4482                   ees0pij=dsqrt(ees0tmp)
4483                 else
4484                   ees0pij=0
4485                 endif
4486                 if (shield_mode.eq.0) then
4487                 fac_shield(i)=1.0d0
4488                 fac_shield(j)=1.0d0
4489                 else
4490                 ees0plist(num_conti,i)=j
4491                 endif
4492 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4493                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4494                 if (ees0tmp.gt.0) then
4495                   ees0mij=dsqrt(ees0tmp)
4496                 else
4497                   ees0mij=0
4498                 endif
4499 !               ees0mij=0.0D0
4500                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4501                      *sss_ele_cut &
4502                      *fac_shield(i)*fac_shield(j)
4503 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4504
4505                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4506                      *sss_ele_cut &
4507                      *fac_shield(i)*fac_shield(j)
4508 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4509
4510 ! Diagnostics. Comment out or remove after debugging!
4511 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4512 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4513 !               ees0m(num_conti,i)=0.0D0
4514 ! End diagnostics.
4515 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4516 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4517 ! Angular derivatives of the contact function
4518                 ees0pij1=fac3/ees0pij
4519                 ees0mij1=fac3/ees0mij
4520                 fac3p=-3.0D0*fac3*rrmij
4521                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4522                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4523 !               ees0mij1=0.0D0
4524                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4525                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4526                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4527                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4528                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4529                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4530                 ecosap=ecosa1+ecosa2
4531                 ecosbp=ecosb1+ecosb2
4532                 ecosgp=ecosg1+ecosg2
4533                 ecosam=ecosa1-ecosa2
4534                 ecosbm=ecosb1-ecosb2
4535                 ecosgm=ecosg1-ecosg2
4536 ! Diagnostics
4537 !               ecosap=ecosa1
4538 !               ecosbp=ecosb1
4539 !               ecosgp=ecosg1
4540 !               ecosam=0.0D0
4541 !               ecosbm=0.0D0
4542 !               ecosgm=0.0D0
4543 ! End diagnostics
4544                 facont_hb(num_conti,i)=fcont
4545                 fprimcont=fprimcont/rij
4546 !d              facont_hb(num_conti,i)=1.0D0
4547 ! Following line is for diagnostics.
4548 !d              fprimcont=0.0D0
4549                 do k=1,3
4550                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4551                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4552                 enddo
4553                 do k=1,3
4554                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4555                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4556                 enddo
4557                 gggp(1)=gggp(1)+ees0pijp*xj &
4558                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4559                 gggp(2)=gggp(2)+ees0pijp*yj &
4560                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4561                 gggp(3)=gggp(3)+ees0pijp*zj &
4562                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4563
4564                 gggm(1)=gggm(1)+ees0mijp*xj &
4565                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4566
4567                 gggm(2)=gggm(2)+ees0mijp*yj &
4568                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4569
4570                 gggm(3)=gggm(3)+ees0mijp*zj &
4571                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4572
4573 ! Derivatives due to the contact function
4574                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4575                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4576                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4577                 do k=1,3
4578 !
4579 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4580 !          following the change of gradient-summation algorithm.
4581 !
4582 !grad                  ghalfp=0.5D0*gggp(k)
4583 !grad                  ghalfm=0.5D0*gggm(k)
4584                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4585                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4586                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4587                      *sss_ele_cut*fac_shield(i)*fac_shield(j) ! &
4588 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4589
4590
4591                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4592                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4593                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4594                      *sss_ele_cut*fac_shield(i)*fac_shield(j)!   &
4595 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4596
4597
4598                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4599                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4600 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4601
4602                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4603                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4604                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4605                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4606 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4607
4608                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4609                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4610                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4611                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4612 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4613
4614                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4615                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4616 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4617
4618                 enddo
4619 ! Diagnostics. Comment out or remove after debugging!
4620 !diag           do k=1,3
4621 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4622 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4623 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4624 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4625 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4626 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4627 !diag           enddo
4628               ENDIF ! wcorr
4629               endif  ! num_conti.le.maxconts
4630             endif  ! fcont.gt.0
4631           endif    ! j.gt.i+1
4632           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4633             do k=1,4
4634               do l=1,3
4635                 ghalf=0.5d0*agg(l,k)
4636                 aggi(l,k)=aggi(l,k)+ghalf
4637                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4638                 aggj(l,k)=aggj(l,k)+ghalf
4639               enddo
4640             enddo
4641             if (j.eq.nres-1 .and. i.lt.j-2) then
4642               do k=1,4
4643                 do l=1,3
4644                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4645                 enddo
4646               enddo
4647             endif
4648           endif
4649  128  continue
4650 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4651       return
4652       end subroutine eelecij
4653 !-----------------------------------------------------------------------------
4654       subroutine eturn3(i,eello_turn3)
4655 ! Third- and fourth-order contributions from turns
4656
4657       use comm_locel
4658 !      implicit real*8 (a-h,o-z)
4659 !      include 'DIMENSIONS'
4660 !      include 'COMMON.IOUNITS'
4661 !      include 'COMMON.GEO'
4662 !      include 'COMMON.VAR'
4663 !      include 'COMMON.LOCAL'
4664 !      include 'COMMON.CHAIN'
4665 !      include 'COMMON.DERIV'
4666 !      include 'COMMON.INTERACT'
4667 !      include 'COMMON.CONTACTS'
4668 !      include 'COMMON.TORSION'
4669 !      include 'COMMON.VECTORS'
4670 !      include 'COMMON.FFIELD'
4671 !      include 'COMMON.CONTROL'
4672       real(kind=8),dimension(3) :: ggg
4673       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4674         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,gpizda1,&
4675        gpizda2,auxgmat1,auxgmatt1,auxgmat2,auxgmatt2
4676
4677       real(kind=8),dimension(2) :: auxvec,auxvec1
4678 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4679       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4680 !el      integer :: num_conti,j1,j2
4681 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4682 !el        dz_normi,xmedi,ymedi,zmedi
4683
4684 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4685 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4686 !el         num_conti,j1,j2
4687 !el local variables
4688       integer :: i,j,l,k,ilist,iresshield
4689       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield,xj,yj
4690       xj=0.0d0
4691       yj=0.0d0
4692       j=i+2
4693 !      write (iout,*) "eturn3",i,j,j1,j2
4694           zj=(c(3,j)+c(3,j+1))/2.0d0
4695             call to_box(xj,yj,zj)
4696             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
4697
4698       a_temp(1,1)=a22
4699       a_temp(1,2)=a23
4700       a_temp(2,1)=a32
4701       a_temp(2,2)=a33
4702 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4703 !
4704 !               Third-order contributions
4705 !
4706 !                 (i+2)o----(i+3)
4707 !                      | |
4708 !                      | |
4709 !                 (i+1)o----i
4710 !
4711 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4712 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4713         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4714         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4715         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4716         call transpose2(auxmat(1,1),auxmat1(1,1))
4717         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4718         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4719         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4720         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4721         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4722
4723         if (shield_mode.eq.0) then
4724         fac_shield(i)=1.0d0
4725         fac_shield(j)=1.0d0
4726         endif
4727
4728         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4729          *fac_shield(i)*fac_shield(j)  &
4730          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4731         eello_t3= &
4732         0.5d0*(pizda(1,1)+pizda(2,2)) &
4733         *fac_shield(i)*fac_shield(j)
4734
4735         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4736                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4737 !C#ifdef NEWCORR
4738 !C Derivatives in theta
4739         gloc(nphi+i,icg)=gloc(nphi+i,icg) &
4740        +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3&
4741         *fac_shield(i)*fac_shield(j) &
4742         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4743
4744         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)&
4745        +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3&
4746         *fac_shield(i)*fac_shield(j) &
4747         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4748
4749
4750 !C#endif
4751
4752
4753
4754           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4755        (shield_mode.gt.0)) then
4756 !C          print *,i,j
4757
4758           do ilist=1,ishield_list(i)
4759            iresshield=shield_list(ilist,i)
4760            do k=1,3
4761            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4762            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4763                    rlocshield &
4764            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4765             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4766              +rlocshield
4767            enddo
4768           enddo
4769           do ilist=1,ishield_list(j)
4770            iresshield=shield_list(ilist,j)
4771            do k=1,3
4772            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4773            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4774                    rlocshield &
4775            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4776            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4777                   +rlocshield
4778
4779            enddo
4780           enddo
4781
4782           do k=1,3
4783             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4784                    grad_shield(k,i)*eello_t3/fac_shield(i)
4785             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4786                    grad_shield(k,j)*eello_t3/fac_shield(j)
4787             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4788                    grad_shield(k,i)*eello_t3/fac_shield(i)
4789             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4790                    grad_shield(k,j)*eello_t3/fac_shield(j)
4791            enddo
4792            endif
4793
4794 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4795 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4796 !d     &    ' eello_turn3_num',4*eello_turn3_num
4797 ! Derivatives in gamma(i)
4798         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4799         call transpose2(auxmat2(1,1),auxmat3(1,1))
4800         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4801         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4802           *fac_shield(i)*fac_shield(j)        &
4803           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4804 ! Derivatives in gamma(i+1)
4805         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4806         call transpose2(auxmat2(1,1),auxmat3(1,1))
4807         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4808         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4809           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4810           *fac_shield(i)*fac_shield(j)        &
4811           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4812
4813 ! Cartesian derivatives
4814         do l=1,3
4815 !            ghalf1=0.5d0*agg(l,1)
4816 !            ghalf2=0.5d0*agg(l,2)
4817 !            ghalf3=0.5d0*agg(l,3)
4818 !            ghalf4=0.5d0*agg(l,4)
4819           a_temp(1,1)=aggi(l,1)!+ghalf1
4820           a_temp(1,2)=aggi(l,2)!+ghalf2
4821           a_temp(2,1)=aggi(l,3)!+ghalf3
4822           a_temp(2,2)=aggi(l,4)!+ghalf4
4823           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4824           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4825             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4826           *fac_shield(i)*fac_shield(j)      &
4827           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4828
4829           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4830           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4831           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4832           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4833           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4834           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4835             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4836           *fac_shield(i)*fac_shield(j)        &
4837           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4838
4839           a_temp(1,1)=aggj(l,1)!+ghalf1
4840           a_temp(1,2)=aggj(l,2)!+ghalf2
4841           a_temp(2,1)=aggj(l,3)!+ghalf3
4842           a_temp(2,2)=aggj(l,4)!+ghalf4
4843           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4844           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4845             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4846           *fac_shield(i)*fac_shield(j)      &
4847           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4848
4849           a_temp(1,1)=aggj1(l,1)
4850           a_temp(1,2)=aggj1(l,2)
4851           a_temp(2,1)=aggj1(l,3)
4852           a_temp(2,2)=aggj1(l,4)
4853           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4854           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4855             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4856           *fac_shield(i)*fac_shield(j)        &
4857           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4858         enddo
4859          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4860           ssgradlipi*eello_t3/4.0d0*lipscale
4861          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4862           ssgradlipj*eello_t3/4.0d0*lipscale
4863          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4864           ssgradlipi*eello_t3/4.0d0*lipscale
4865          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4866           ssgradlipj*eello_t3/4.0d0*lipscale
4867
4868       return
4869       end subroutine eturn3
4870 !-----------------------------------------------------------------------------
4871       subroutine eturn4(i,eello_turn4)
4872 ! Third- and fourth-order contributions from turns
4873
4874       use comm_locel
4875 !      implicit real*8 (a-h,o-z)
4876 !      include 'DIMENSIONS'
4877 !      include 'COMMON.IOUNITS'
4878 !      include 'COMMON.GEO'
4879 !      include 'COMMON.VAR'
4880 !      include 'COMMON.LOCAL'
4881 !      include 'COMMON.CHAIN'
4882 !      include 'COMMON.DERIV'
4883 !      include 'COMMON.INTERACT'
4884 !      include 'COMMON.CONTACTS'
4885 !      include 'COMMON.TORSION'
4886 !      include 'COMMON.VECTORS'
4887 !      include 'COMMON.FFIELD'
4888 !      include 'COMMON.CONTROL'
4889       real(kind=8),dimension(3) :: ggg
4890       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4891         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,&
4892         gte1t,gte2t,gte3t,&
4893         gte1a,gtae3,gtae3e2, ae3gte2,&
4894         gtEpizda1,gtEpizda2,gtEpizda3
4895
4896       real(kind=8),dimension(2) :: auxvec,auxvec1,auxgEvec1,auxgEvec2,&
4897        auxgEvec3,auxgvec
4898
4899 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4900       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4901 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4902 !el        dz_normi,xmedi,ymedi,zmedi
4903 !el      integer :: num_conti,j1,j2
4904 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4905 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4906 !el          num_conti,j1,j2
4907 !el local variables
4908       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4909       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4910          rlocshield,gs23,gs32,gsE13,gs13,gs21,gsE31,gsEE1,gsEE2,gsEE3,xj,yj
4911       xj=0.0d0
4912       yj=0.0d0
4913       j=i+3
4914 !      if (j.ne.20) return
4915 !      print *,i,j,gshieldc_t4(2,j),gshieldc_t4(2,j+1)
4916 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4917 !
4918 !               Fourth-order contributions
4919 !
4920 !                 (i+3)o----(i+4)
4921 !                     /  |
4922 !               (i+2)o   |
4923 !                     \  |
4924 !                 (i+1)o----i
4925 !
4926 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4927 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4928 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4929           zj=(c(3,j)+c(3,j+1))/2.0d0
4930             call to_box(xj,yj,zj)
4931             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
4932
4933
4934         a_temp(1,1)=a22
4935         a_temp(1,2)=a23
4936         a_temp(2,1)=a32
4937         a_temp(2,2)=a33
4938         iti1=i+1
4939         iti2=i+2
4940         iti3=i+3
4941 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4942         call transpose2(EUg(1,1,i+1),e1t(1,1))
4943         call transpose2(Eug(1,1,i+2),e2t(1,1))
4944         call transpose2(Eug(1,1,i+3),e3t(1,1))
4945 !C Ematrix derivative in theta
4946         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4947         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4948         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4949
4950         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4951         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4952         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4953         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4954 !c       auxalary matrix of E i+1
4955         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4956         s1=scalar2(b1(1,iti2),auxvec(1))
4957 !c derivative of theta i+2 with constant i+3
4958         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4959 !c derivative of theta i+2 with constant i+2
4960         gs32=scalar2(b1(1,i+2),auxgvec(1))
4961 !c derivative of E matix in theta of i+1
4962         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4963
4964         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4965         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4966         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4967 !c auxilary matrix auxgvec of Ub2 with constant E matirx
4968         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4969 !c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4970         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4971         s2=scalar2(b1(1,i+1),auxvec(1))
4972 !c derivative of theta i+1 with constant i+3
4973         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4974 !c derivative of theta i+2 with constant i+1
4975         gs21=scalar2(b1(1,i+1),auxgvec(1))
4976 !c derivative of theta i+3 with constant i+1
4977         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4978
4979         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4980         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4981 !c ae3gte2 is derivative over i+2
4982         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4983
4984         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4985         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4986 !c i+2
4987         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4988 !c i+3
4989         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4990
4991         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4992         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4993         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4994         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4995         if (shield_mode.eq.0) then
4996         fac_shield(i)=1.0
4997         fac_shield(j)=1.0
4998         endif
4999
5000         eello_turn4=eello_turn4-(s1+s2+s3) &
5001         *fac_shield(i)*fac_shield(j)       &
5002         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5003         eello_t4=-(s1+s2+s3)  &
5004           *fac_shield(i)*fac_shield(j)
5005 !C Now derivative over shield:
5006           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
5007          (shield_mode.gt.0)) then
5008 !C          print *,i,j
5009
5010           do ilist=1,ishield_list(i)
5011            iresshield=shield_list(ilist,i)
5012            do k=1,3
5013            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5014 !           print *,"rlocshield",rlocshield,grad_shield_side(k,ilist,i),iresshield
5015            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5016                    rlocshield &
5017             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5018             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5019            +rlocshield
5020            enddo
5021           enddo
5022           do ilist=1,ishield_list(j)
5023            iresshield=shield_list(ilist,j)
5024            do k=1,3
5025 !           print *,"rlocshieldj",j,rlocshield,grad_shield_side(k,ilist,j),iresshield
5026            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5027            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5028                    rlocshield  &
5029            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5030            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5031                   +rlocshield
5032 !            print *,"after", gshieldc_t4(k,iresshield-1),iresshield-1,gshieldc_t4(k,iresshield)
5033
5034            enddo
5035           enddo
5036           do k=1,3
5037             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
5038                    grad_shield(k,i)*eello_t4/fac_shield(i)
5039             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
5040                    grad_shield(k,j)*eello_t4/fac_shield(j)
5041             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
5042                    grad_shield(k,i)*eello_t4/fac_shield(i)
5043             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
5044                    grad_shield(k,j)*eello_t4/fac_shield(j)
5045 !           print *,"gshieldc_t4(k,j+1)",j,gshieldc_t4(k,j+1)
5046            enddo
5047            endif
5048 #ifdef NEWCORR
5049         gloc(nphi+i,icg)=gloc(nphi+i,icg)&
5050                        -(gs13+gsE13+gsEE1)*wturn4&
5051        *fac_shield(i)*fac_shield(j)
5052         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)&
5053                          -(gs23+gs21+gsEE2)*wturn4&
5054        *fac_shield(i)*fac_shield(j)
5055
5056         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)&
5057                          -(gs32+gsE31+gsEE3)*wturn4&
5058        *fac_shield(i)*fac_shield(j)
5059
5060 !c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5061 !c     &   gs2
5062 #endif
5063         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5064            'eturn4',i,j,-(s1+s2+s3)
5065 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5066 !d     &    ' eello_turn4_num',8*eello_turn4_num
5067 ! Derivatives in gamma(i)
5068         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5069         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5070         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5071         s1=scalar2(b1(1,i+1),auxvec(1))
5072         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5073         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5074         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
5075        *fac_shield(i)*fac_shield(j)  &
5076        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5077
5078 ! Derivatives in gamma(i+1)
5079         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5080         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5081         s2=scalar2(b1(1,iti1),auxvec(1))
5082         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5083         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5084         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5085         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
5086        *fac_shield(i)*fac_shield(j)  &
5087        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5088
5089 ! Derivatives in gamma(i+2)
5090         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5091         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5092         s1=scalar2(b1(1,iti2),auxvec(1))
5093         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5094         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5095         s2=scalar2(b1(1,iti1),auxvec(1))
5096         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5097         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5098         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5099         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
5100        *fac_shield(i)*fac_shield(j)  &
5101        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5102
5103 ! Cartesian derivatives
5104 ! Derivatives of this turn contributions in DC(i+2)
5105         if (j.lt.nres-1) then
5106           do l=1,3
5107             a_temp(1,1)=agg(l,1)
5108             a_temp(1,2)=agg(l,2)
5109             a_temp(2,1)=agg(l,3)
5110             a_temp(2,2)=agg(l,4)
5111             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5112             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5113             s1=scalar2(b1(1,iti2),auxvec(1))
5114             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5115             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5116             s2=scalar2(b1(1,iti1),auxvec(1))
5117             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5118             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5119             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5120             ggg(l)=-(s1+s2+s3)
5121             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
5122        *fac_shield(i)*fac_shield(j)  &
5123        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5124
5125           enddo
5126         endif
5127 ! Remaining derivatives of this turn contribution
5128         do l=1,3
5129           a_temp(1,1)=aggi(l,1)
5130           a_temp(1,2)=aggi(l,2)
5131           a_temp(2,1)=aggi(l,3)
5132           a_temp(2,2)=aggi(l,4)
5133           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5134           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5135           s1=scalar2(b1(1,iti2),auxvec(1))
5136           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5137           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5138           s2=scalar2(b1(1,iti1),auxvec(1))
5139           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5140           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5141           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5142           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
5143          *fac_shield(i)*fac_shield(j)  &
5144          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5145
5146
5147           a_temp(1,1)=aggi1(l,1)
5148           a_temp(1,2)=aggi1(l,2)
5149           a_temp(2,1)=aggi1(l,3)
5150           a_temp(2,2)=aggi1(l,4)
5151           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5152           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5153           s1=scalar2(b1(1,iti2),auxvec(1))
5154           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5155           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5156           s2=scalar2(b1(1,iti1),auxvec(1))
5157           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5158           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5159           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5160           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
5161          *fac_shield(i)*fac_shield(j)  &
5162          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5163
5164
5165           a_temp(1,1)=aggj(l,1)
5166           a_temp(1,2)=aggj(l,2)
5167           a_temp(2,1)=aggj(l,3)
5168           a_temp(2,2)=aggj(l,4)
5169           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5170           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5171           s1=scalar2(b1(1,iti2),auxvec(1))
5172           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5173           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5174           s2=scalar2(b1(1,iti1),auxvec(1))
5175           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5176           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5177           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5178 !        if (j.lt.nres-1) then
5179           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
5180          *fac_shield(i)*fac_shield(j)  &
5181          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5182 !        endif
5183
5184           a_temp(1,1)=aggj1(l,1)
5185           a_temp(1,2)=aggj1(l,2)
5186           a_temp(2,1)=aggj1(l,3)
5187           a_temp(2,2)=aggj1(l,4)
5188           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5189           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5190           s1=scalar2(b1(1,iti2),auxvec(1))
5191           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5192           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5193           s2=scalar2(b1(1,iti1),auxvec(1))
5194           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5195           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5196           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5197 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5198 !        if (j.lt.nres-1) then
5199 !          print *,"juest before",j1, gcorr4_turn(l,j1)
5200           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
5201          *fac_shield(i)*fac_shield(j)  &
5202          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5203 !            if (shield_mode.gt.0) then
5204 !             print *,"juest after",j1, gcorr4_turn(l,j1),gshieldc_t4(k,j1),gshieldc_loc_t4(k,j1),gel_loc_turn4(i+2)
5205 !            else
5206 !             print *,"juest after",j1, gcorr4_turn(l,j1),gel_loc_turn4(i+2)
5207 !            endif
5208 !         endif
5209         enddo
5210          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
5211           ssgradlipi*eello_t4/4.0d0*lipscale
5212          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
5213           ssgradlipj*eello_t4/4.0d0*lipscale
5214          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
5215           ssgradlipi*eello_t4/4.0d0*lipscale
5216          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
5217           ssgradlipj*eello_t4/4.0d0*lipscale
5218
5219       return
5220       end subroutine eturn4
5221 !-----------------------------------------------------------------------------
5222       subroutine unormderiv(u,ugrad,unorm,ungrad)
5223 ! This subroutine computes the derivatives of a normalized vector u, given
5224 ! the derivatives computed without normalization conditions, ugrad. Returns
5225 ! ungrad.
5226 !      implicit none
5227       real(kind=8),dimension(3) :: u,vec
5228       real(kind=8),dimension(3,3) ::ugrad,ungrad
5229       real(kind=8) :: unorm      !,scalar
5230       integer :: i,j
5231 !      write (2,*) 'ugrad',ugrad
5232 !      write (2,*) 'u',u
5233       do i=1,3
5234         vec(i)=scalar(ugrad(1,i),u(1))
5235       enddo
5236 !      write (2,*) 'vec',vec
5237       do i=1,3
5238         do j=1,3
5239           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5240         enddo
5241       enddo
5242 !      write (2,*) 'ungrad',ungrad
5243       return
5244       end subroutine unormderiv
5245 !-----------------------------------------------------------------------------
5246       subroutine escp_soft_sphere(evdw2,evdw2_14)
5247 !
5248 ! This subroutine calculates the excluded-volume interaction energy between
5249 ! peptide-group centers and side chains and its gradient in virtual-bond and
5250 ! side-chain vectors.
5251 !
5252 !      implicit real*8 (a-h,o-z)
5253 !      include 'DIMENSIONS'
5254 !      include 'COMMON.GEO'
5255 !      include 'COMMON.VAR'
5256 !      include 'COMMON.LOCAL'
5257 !      include 'COMMON.CHAIN'
5258 !      include 'COMMON.DERIV'
5259 !      include 'COMMON.INTERACT'
5260 !      include 'COMMON.FFIELD'
5261 !      include 'COMMON.IOUNITS'
5262 !      include 'COMMON.CONTROL'
5263       real(kind=8),dimension(3) :: ggg
5264 !el local variables
5265       integer :: i,iint,j,k,iteli,itypj
5266       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
5267                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
5268
5269       evdw2=0.0D0
5270       evdw2_14=0.0d0
5271       r0_scp=4.5d0
5272 !d    print '(a)','Enter ESCP'
5273 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5274       do i=iatscp_s,iatscp_e
5275         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5276         iteli=itel(i)
5277         xi=0.5D0*(c(1,i)+c(1,i+1))
5278         yi=0.5D0*(c(2,i)+c(2,i+1))
5279         zi=0.5D0*(c(3,i)+c(3,i+1))
5280           call to_box(xi,yi,zi)
5281
5282         do iint=1,nscp_gr(i)
5283
5284         do j=iscpstart(i,iint),iscpend(i,iint)
5285           if (itype(j,1).eq.ntyp1) cycle
5286           itypj=iabs(itype(j,1))
5287 ! Uncomment following three lines for SC-p interactions
5288 !         xj=c(1,nres+j)-xi
5289 !         yj=c(2,nres+j)-yi
5290 !         zj=c(3,nres+j)-zi
5291 ! Uncomment following three lines for Ca-p interactions
5292           xj=c(1,j)-xi
5293           yj=c(2,j)-yi
5294           zj=c(3,j)-zi
5295           call to_box(xj,yj,zj)
5296           xj=boxshift(xj-xi,boxxsize)
5297           yj=boxshift(yj-yi,boxysize)
5298           zj=boxshift(zj-zi,boxzsize)
5299           rij=xj*xj+yj*yj+zj*zj
5300           r0ij=r0_scp
5301           r0ijsq=r0ij*r0ij
5302           if (rij.lt.r0ijsq) then
5303             evdwij=0.25d0*(rij-r0ijsq)**2
5304             fac=rij-r0ijsq
5305           else
5306             evdwij=0.0d0
5307             fac=0.0d0
5308           endif
5309           evdw2=evdw2+evdwij
5310 !
5311 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5312 !
5313           ggg(1)=xj*fac
5314           ggg(2)=yj*fac
5315           ggg(3)=zj*fac
5316 !grad          if (j.lt.i) then
5317 !d          write (iout,*) 'j<i'
5318 ! Uncomment following three lines for SC-p interactions
5319 !           do k=1,3
5320 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5321 !           enddo
5322 !grad          else
5323 !d          write (iout,*) 'j>i'
5324 !grad            do k=1,3
5325 !grad              ggg(k)=-ggg(k)
5326 ! Uncomment following line for SC-p interactions
5327 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5328 !grad            enddo
5329 !grad          endif
5330 !grad          do k=1,3
5331 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5332 !grad          enddo
5333 !grad          kstart=min0(i+1,j)
5334 !grad          kend=max0(i-1,j-1)
5335 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5336 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5337 !grad          do k=kstart,kend
5338 !grad            do l=1,3
5339 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5340 !grad            enddo
5341 !grad          enddo
5342           do k=1,3
5343             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5344             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5345           enddo
5346         enddo
5347
5348         enddo ! iint
5349       enddo ! i
5350       return
5351       end subroutine escp_soft_sphere
5352 !-----------------------------------------------------------------------------
5353       subroutine escp(evdw2,evdw2_14)
5354 !
5355 ! This subroutine calculates the excluded-volume interaction energy between
5356 ! peptide-group centers and side chains and its gradient in virtual-bond and
5357 ! side-chain vectors.
5358 !
5359 !      implicit real*8 (a-h,o-z)
5360 !      include 'DIMENSIONS'
5361 !      include 'COMMON.GEO'
5362 !      include 'COMMON.VAR'
5363 !      include 'COMMON.LOCAL'
5364 !      include 'COMMON.CHAIN'
5365 !      include 'COMMON.DERIV'
5366 !      include 'COMMON.INTERACT'
5367 !      include 'COMMON.FFIELD'
5368 !      include 'COMMON.IOUNITS'
5369 !      include 'COMMON.CONTROL'
5370       real(kind=8),dimension(3) :: ggg
5371 !el local variables
5372       integer :: i,iint,j,k,iteli,itypj,subchap,icont
5373       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
5374                    e1,e2,evdwij,rij
5375       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
5376                     dist_temp, dist_init
5377       integer xshift,yshift,zshift
5378
5379       evdw2=0.0D0
5380       evdw2_14=0.0d0
5381 !d    print '(a)','Enter ESCP'
5382 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5383 !      do i=iatscp_s,iatscp_e
5384        do icont=g_listscp_start,g_listscp_end
5385         i=newcontlistscpi(icont)
5386         j=newcontlistscpj(icont)
5387         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5388         iteli=itel(i)
5389         xi=0.5D0*(c(1,i)+c(1,i+1))
5390         yi=0.5D0*(c(2,i)+c(2,i+1))
5391         zi=0.5D0*(c(3,i)+c(3,i+1))
5392         call to_box(xi,yi,zi)
5393
5394 !        do iint=1,nscp_gr(i)
5395
5396 !        do j=iscpstart(i,iint),iscpend(i,iint)
5397           itypj=iabs(itype(j,1))
5398           if (itypj.eq.ntyp1) cycle
5399 ! Uncomment following three lines for SC-p interactions
5400 !         xj=c(1,nres+j)-xi
5401 !         yj=c(2,nres+j)-yi
5402 !         zj=c(3,nres+j)-zi
5403 ! Uncomment following three lines for Ca-p interactions
5404 !          xj=c(1,j)-xi
5405 !          yj=c(2,j)-yi
5406 !          zj=c(3,j)-zi
5407           xj=c(1,j)
5408           yj=c(2,j)
5409           zj=c(3,j)
5410
5411           call to_box(xj,yj,zj)
5412           xj=boxshift(xj-xi,boxxsize)
5413           yj=boxshift(yj-yi,boxysize)
5414           zj=boxshift(zj-zi,boxzsize)
5415
5416           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5417           rij=dsqrt(1.0d0/rrij)
5418             sss_ele_cut=sscale_ele(rij)
5419             sss_ele_grad=sscagrad_ele(rij)
5420 !            print *,sss_ele_cut,sss_ele_grad,&
5421 !            (rij),r_cut_ele,rlamb_ele
5422             if (sss_ele_cut.le.0.0) cycle
5423           fac=rrij**expon2
5424           e1=fac*fac*aad(itypj,iteli)
5425           e2=fac*bad(itypj,iteli)
5426           if (iabs(j-i) .le. 2) then
5427             e1=scal14*e1
5428             e2=scal14*e2
5429             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5430           endif
5431           evdwij=e1+e2
5432           evdw2=evdw2+evdwij*sss_ele_cut
5433 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5434 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5435           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5436              'evdw2',i,j,evdwij
5437 !
5438 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5439 !
5440           fac=-(evdwij+e1)*rrij*sss_ele_cut
5441           fac=fac+evdwij*sss_ele_grad/rij/expon
5442           ggg(1)=xj*fac
5443           ggg(2)=yj*fac
5444           ggg(3)=zj*fac
5445 !grad          if (j.lt.i) then
5446 !d          write (iout,*) 'j<i'
5447 ! Uncomment following three lines for SC-p interactions
5448 !           do k=1,3
5449 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5450 !           enddo
5451 !grad          else
5452 !d          write (iout,*) 'j>i'
5453 !grad            do k=1,3
5454 !grad              ggg(k)=-ggg(k)
5455 ! Uncomment following line for SC-p interactions
5456 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5457 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5458 !grad            enddo
5459 !grad          endif
5460 !grad          do k=1,3
5461 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5462 !grad          enddo
5463 !grad          kstart=min0(i+1,j)
5464 !grad          kend=max0(i-1,j-1)
5465 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5466 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5467 !grad          do k=kstart,kend
5468 !grad            do l=1,3
5469 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5470 !grad            enddo
5471 !grad          enddo
5472           do k=1,3
5473             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5474             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5475           enddo
5476 !        enddo
5477
5478 !        enddo ! iint
5479       enddo ! i
5480       do i=1,nct
5481         do j=1,3
5482           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5483           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5484           gradx_scp(j,i)=expon*gradx_scp(j,i)
5485         enddo
5486       enddo
5487 !******************************************************************************
5488 !
5489 !                              N O T E !!!
5490 !
5491 ! To save time the factor EXPON has been extracted from ALL components
5492 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5493 ! use!
5494 !
5495 !******************************************************************************
5496       return
5497       end subroutine escp
5498 !-----------------------------------------------------------------------------
5499       subroutine edis(ehpb)
5500 !
5501 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5502 !
5503 !      implicit real*8 (a-h,o-z)
5504 !      include 'DIMENSIONS'
5505 !      include 'COMMON.SBRIDGE'
5506 !      include 'COMMON.CHAIN'
5507 !      include 'COMMON.DERIV'
5508 !      include 'COMMON.VAR'
5509 !      include 'COMMON.INTERACT'
5510 !      include 'COMMON.IOUNITS'
5511       real(kind=8),dimension(3) :: ggg
5512 !el local variables
5513       integer :: i,j,ii,jj,iii,jjj,k
5514       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5515
5516       ehpb=0.0D0
5517 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5518 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5519       if (link_end.eq.0) return
5520       do i=link_start,link_end
5521 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5522 ! CA-CA distance used in regularization of structure.
5523         ii=ihpb(i)
5524         jj=jhpb(i)
5525 ! iii and jjj point to the residues for which the distance is assigned.
5526         if (ii.gt.nres) then
5527           iii=ii-nres
5528           jjj=jj-nres
5529         else
5530           iii=ii
5531           jjj=jj
5532         endif
5533 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5534 !     &    dhpb(i),dhpb1(i),forcon(i)
5535 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5536 !    distance and angle dependent SS bond potential.
5537 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5538 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5539         if (.not.dyn_ss .and. i.le.nss) then
5540 ! 15/02/13 CC dynamic SSbond - additional check
5541          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5542         iabs(itype(jjj,1)).eq.1) then
5543           call ssbond_ene(iii,jjj,eij)
5544           ehpb=ehpb+2*eij
5545 !d          write (iout,*) "eij",eij
5546          endif
5547         else if (ii.gt.nres .and. jj.gt.nres) then
5548 !c Restraints from contact prediction
5549           dd=dist(ii,jj)
5550           if (constr_dist.eq.11) then
5551             ehpb=ehpb+fordepth(i)**4.0d0 &
5552                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5553             fac=fordepth(i)**4.0d0 &
5554                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5555           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5556             ehpb,fordepth(i),dd
5557            else
5558           if (dhpb1(i).gt.0.0d0) then
5559             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5560             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5561 !c            write (iout,*) "beta nmr",
5562 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5563           else
5564             dd=dist(ii,jj)
5565             rdis=dd-dhpb(i)
5566 !C Get the force constant corresponding to this distance.
5567             waga=forcon(i)
5568 !C Calculate the contribution to energy.
5569             ehpb=ehpb+waga*rdis*rdis
5570 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5571 !C
5572 !C Evaluate gradient.
5573 !C
5574             fac=waga*rdis/dd
5575           endif
5576           endif
5577           do j=1,3
5578             ggg(j)=fac*(c(j,jj)-c(j,ii))
5579           enddo
5580           do j=1,3
5581             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5582             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5583           enddo
5584           do k=1,3
5585             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5586             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5587           enddo
5588         else
5589           dd=dist(ii,jj)
5590           if (constr_dist.eq.11) then
5591             ehpb=ehpb+fordepth(i)**4.0d0 &
5592                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5593             fac=fordepth(i)**4.0d0 &
5594                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5595           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5596          ehpb,fordepth(i),dd
5597            else
5598           if (dhpb1(i).gt.0.0d0) then
5599             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5600             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5601 !c            write (iout,*) "alph nmr",
5602 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5603           else
5604             rdis=dd-dhpb(i)
5605 !C Get the force constant corresponding to this distance.
5606             waga=forcon(i)
5607 !C Calculate the contribution to energy.
5608             ehpb=ehpb+waga*rdis*rdis
5609 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5610 !C
5611 !C Evaluate gradient.
5612 !C
5613             fac=waga*rdis/dd
5614           endif
5615           endif
5616
5617             do j=1,3
5618               ggg(j)=fac*(c(j,jj)-c(j,ii))
5619             enddo
5620 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5621 !C If this is a SC-SC distance, we need to calculate the contributions to the
5622 !C Cartesian gradient in the SC vectors (ghpbx).
5623           if (iii.lt.ii) then
5624           do j=1,3
5625             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5626             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5627           enddo
5628           endif
5629 !cgrad        do j=iii,jjj-1
5630 !cgrad          do k=1,3
5631 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5632 !cgrad          enddo
5633 !cgrad        enddo
5634           do k=1,3
5635             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5636             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5637           enddo
5638         endif
5639       enddo
5640       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5641
5642       return
5643       end subroutine edis
5644 !-----------------------------------------------------------------------------
5645       subroutine ssbond_ene(i,j,eij)
5646 !
5647 ! Calculate the distance and angle dependent SS-bond potential energy
5648 ! using a free-energy function derived based on RHF/6-31G** ab initio
5649 ! calculations of diethyl disulfide.
5650 !
5651 ! A. Liwo and U. Kozlowska, 11/24/03
5652 !
5653 !      implicit real*8 (a-h,o-z)
5654 !      include 'DIMENSIONS'
5655 !      include 'COMMON.SBRIDGE'
5656 !      include 'COMMON.CHAIN'
5657 !      include 'COMMON.DERIV'
5658 !      include 'COMMON.LOCAL'
5659 !      include 'COMMON.INTERACT'
5660 !      include 'COMMON.VAR'
5661 !      include 'COMMON.IOUNITS'
5662       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5663 !el local variables
5664       integer :: i,j,itypi,itypj,k
5665       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5666                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5667                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5668                    cosphi,ggk
5669
5670       itypi=iabs(itype(i,1))
5671       xi=c(1,nres+i)
5672       yi=c(2,nres+i)
5673       zi=c(3,nres+i)
5674           call to_box(xi,yi,zi)
5675
5676       dxi=dc_norm(1,nres+i)
5677       dyi=dc_norm(2,nres+i)
5678       dzi=dc_norm(3,nres+i)
5679 !      dsci_inv=dsc_inv(itypi)
5680       dsci_inv=vbld_inv(nres+i)
5681       itypj=iabs(itype(j,1))
5682 !      dscj_inv=dsc_inv(itypj)
5683       dscj_inv=vbld_inv(nres+j)
5684       xj=c(1,nres+j)-xi
5685       yj=c(2,nres+j)-yi
5686       zj=c(3,nres+j)-zi
5687           call to_box(xj,yj,zj)
5688       dxj=dc_norm(1,nres+j)
5689       dyj=dc_norm(2,nres+j)
5690       dzj=dc_norm(3,nres+j)
5691       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5692       rij=dsqrt(rrij)
5693       erij(1)=xj*rij
5694       erij(2)=yj*rij
5695       erij(3)=zj*rij
5696       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5697       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5698       om12=dxi*dxj+dyi*dyj+dzi*dzj
5699       do k=1,3
5700         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5701         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5702       enddo
5703       rij=1.0d0/rij
5704       deltad=rij-d0cm
5705       deltat1=1.0d0-om1
5706       deltat2=1.0d0+om2
5707       deltat12=om2-om1+2.0d0
5708       cosphi=om12-om1*om2
5709       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5710         +akct*deltad*deltat12 &
5711         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5712 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5713 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5714 !     &  " deltat12",deltat12," eij",eij
5715       ed=2*akcm*deltad+akct*deltat12
5716       pom1=akct*deltad
5717       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5718       eom1=-2*akth*deltat1-pom1-om2*pom2
5719       eom2= 2*akth*deltat2+pom1-om1*pom2
5720       eom12=pom2
5721       do k=1,3
5722         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5723         ghpbx(k,i)=ghpbx(k,i)-ggk &
5724                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5725                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5726         ghpbx(k,j)=ghpbx(k,j)+ggk &
5727                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5728                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5729         ghpbc(k,i)=ghpbc(k,i)-ggk
5730         ghpbc(k,j)=ghpbc(k,j)+ggk
5731       enddo
5732 !
5733 ! Calculate the components of the gradient in DC and X
5734 !
5735 !grad      do k=i,j-1
5736 !grad        do l=1,3
5737 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5738 !grad        enddo
5739 !grad      enddo
5740       return
5741       end subroutine ssbond_ene
5742 !-----------------------------------------------------------------------------
5743       subroutine ebond(estr)
5744 !
5745 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5746 !
5747 !      implicit real*8 (a-h,o-z)
5748 !      include 'DIMENSIONS'
5749 !      include 'COMMON.LOCAL'
5750 !      include 'COMMON.GEO'
5751 !      include 'COMMON.INTERACT'
5752 !      include 'COMMON.DERIV'
5753 !      include 'COMMON.VAR'
5754 !      include 'COMMON.CHAIN'
5755 !      include 'COMMON.IOUNITS'
5756 !      include 'COMMON.NAMES'
5757 !      include 'COMMON.FFIELD'
5758 !      include 'COMMON.CONTROL'
5759 !      include 'COMMON.SETUP'
5760       real(kind=8),dimension(3) :: u,ud
5761 !el local variables
5762       integer :: i,j,iti,nbi,k
5763       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5764                    uprod1,uprod2
5765
5766       estr=0.0d0
5767       estr1=0.0d0
5768 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5769 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5770
5771       do i=ibondp_start,ibondp_end
5772         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5773         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5774 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5775 !C          do j=1,3
5776 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5777 !C            *dc(j,i-1)/vbld(i)
5778 !C          enddo
5779 !C          if (energy_dec) write(iout,*) &
5780 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5781         diff = vbld(i)-vbldpDUM
5782         else
5783         diff = vbld(i)-vbldp0
5784         endif
5785         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5786            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5787         estr=estr+diff*diff
5788         do j=1,3
5789           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5790         enddo
5791 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5792 !        endif
5793       enddo
5794       estr=0.5d0*AKP*estr+estr1
5795 !      print *,"estr_bb",estr,AKP
5796 !
5797 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5798 !
5799       do i=ibond_start,ibond_end
5800         iti=iabs(itype(i,1))
5801         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5802         if (iti.ne.10 .and. iti.ne.ntyp1) then
5803           nbi=nbondterm(iti)
5804           if (nbi.eq.1) then
5805             diff=vbld(i+nres)-vbldsc0(1,iti)
5806             if (energy_dec) write (iout,*) &
5807             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5808             AKSC(1,iti),AKSC(1,iti)*diff*diff
5809             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5810 !            print *,"estr_sc",estr
5811             do j=1,3
5812               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5813             enddo
5814           else
5815             do j=1,nbi
5816               diff=vbld(i+nres)-vbldsc0(j,iti)
5817               ud(j)=aksc(j,iti)*diff
5818               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5819             enddo
5820             uprod=u(1)
5821             do j=2,nbi
5822               uprod=uprod*u(j)
5823             enddo
5824             usum=0.0d0
5825             usumsqder=0.0d0
5826             do j=1,nbi
5827               uprod1=1.0d0
5828               uprod2=1.0d0
5829               do k=1,nbi
5830                 if (k.ne.j) then
5831                   uprod1=uprod1*u(k)
5832                   uprod2=uprod2*u(k)*u(k)
5833                 endif
5834               enddo
5835               usum=usum+uprod1
5836               usumsqder=usumsqder+ud(j)*uprod2
5837             enddo
5838             estr=estr+uprod/usum
5839 !            print *,"estr_sc",estr,i
5840
5841              if (energy_dec) write (iout,*) &
5842             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5843             AKSC(1,iti),uprod/usum
5844             do j=1,3
5845              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5846             enddo
5847           endif
5848         endif
5849       enddo
5850       return
5851       end subroutine ebond
5852 #ifdef CRYST_THETA
5853 !-----------------------------------------------------------------------------
5854       subroutine ebend(etheta)
5855 !
5856 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5857 ! angles gamma and its derivatives in consecutive thetas and gammas.
5858 !
5859       use comm_calcthet
5860 !      implicit real*8 (a-h,o-z)
5861 !      include 'DIMENSIONS'
5862 !      include 'COMMON.LOCAL'
5863 !      include 'COMMON.GEO'
5864 !      include 'COMMON.INTERACT'
5865 !      include 'COMMON.DERIV'
5866 !      include 'COMMON.VAR'
5867 !      include 'COMMON.CHAIN'
5868 !      include 'COMMON.IOUNITS'
5869 !      include 'COMMON.NAMES'
5870 !      include 'COMMON.FFIELD'
5871 !      include 'COMMON.CONTROL'
5872 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5873 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5874 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5875 !el      integer :: it
5876 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5877 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5878 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5879 !el local variables
5880       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5881        ichir21,ichir22
5882       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5883        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5884        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5885       real(kind=8),dimension(2) :: y,z
5886
5887       delta=0.02d0*pi
5888 !      time11=dexp(-2*time)
5889 !      time12=1.0d0
5890       etheta=0.0D0
5891 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5892       do i=ithet_start,ithet_end
5893         if (itype(i-1,1).eq.ntyp1) cycle
5894 ! Zero the energy function and its derivative at 0 or pi.
5895         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5896         it=itype(i-1,1)
5897         ichir1=isign(1,itype(i-2,1))
5898         ichir2=isign(1,itype(i,1))
5899          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
5900          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
5901          if (itype(i-1,1).eq.10) then
5902           itype1=isign(10,itype(i-2,1))
5903           ichir11=isign(1,itype(i-2,1))
5904           ichir12=isign(1,itype(i-2,1))
5905           itype2=isign(10,itype(i,1))
5906           ichir21=isign(1,itype(i,1))
5907           ichir22=isign(1,itype(i,1))
5908          endif
5909
5910         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
5911 #ifdef OSF
5912           phii=phi(i)
5913           if (phii.ne.phii) phii=150.0
5914 #else
5915           phii=phi(i)
5916 #endif
5917           y(1)=dcos(phii)
5918           y(2)=dsin(phii)
5919         else
5920           y(1)=0.0D0
5921           y(2)=0.0D0
5922         endif
5923         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
5924 #ifdef OSF
5925           phii1=phi(i+1)
5926           if (phii1.ne.phii1) phii1=150.0
5927           phii1=pinorm(phii1)
5928           z(1)=cos(phii1)
5929 #else
5930           phii1=phi(i+1)
5931           z(1)=dcos(phii1)
5932 #endif
5933           z(2)=dsin(phii1)
5934         else
5935           z(1)=0.0D0
5936           z(2)=0.0D0
5937         endif
5938 ! Calculate the "mean" value of theta from the part of the distribution
5939 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5940 ! In following comments this theta will be referred to as t_c.
5941         thet_pred_mean=0.0d0
5942         do k=1,2
5943             athetk=athet(k,it,ichir1,ichir2)
5944             bthetk=bthet(k,it,ichir1,ichir2)
5945           if (it.eq.10) then
5946              athetk=athet(k,itype1,ichir11,ichir12)
5947              bthetk=bthet(k,itype2,ichir21,ichir22)
5948           endif
5949          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5950         enddo
5951         dthett=thet_pred_mean*ssd
5952         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5953 ! Derivatives of the "mean" values in gamma1 and gamma2.
5954         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5955                +athet(2,it,ichir1,ichir2)*y(1))*ss
5956         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5957                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5958          if (it.eq.10) then
5959         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5960              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5961         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5962                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5963          endif
5964         if (theta(i).gt.pi-delta) then
5965           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5966                E_tc0)
5967           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5968           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5969           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5970               E_theta)
5971           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
5972               E_tc)
5973         else if (theta(i).lt.delta) then
5974           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5975           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5976           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
5977               E_theta)
5978           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5979           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
5980               E_tc)
5981         else
5982           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
5983               E_theta,E_tc)
5984         endif
5985         etheta=etheta+ethetai
5986         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5987             'ebend',i,ethetai
5988         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5989         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5990         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5991       enddo
5992 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5993
5994 ! Ufff.... We've done all this!!!
5995       return
5996       end subroutine ebend
5997 !-----------------------------------------------------------------------------
5998       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
5999
6000       use comm_calcthet
6001 !      implicit real*8 (a-h,o-z)
6002 !      include 'DIMENSIONS'
6003 !      include 'COMMON.LOCAL'
6004 !      include 'COMMON.IOUNITS'
6005 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6006 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6007 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6008       integer :: i,j,k
6009       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
6010 !el      integer :: it
6011 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6012 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6013 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6014 !el local variables
6015       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
6016        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6017
6018 ! Calculate the contributions to both Gaussian lobes.
6019 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6020 ! The "polynomial part" of the "standard deviation" of this part of
6021 ! the distribution.
6022         sig=polthet(3,it)
6023         do j=2,0,-1
6024           sig=sig*thet_pred_mean+polthet(j,it)
6025         enddo
6026 ! Derivative of the "interior part" of the "standard deviation of the"
6027 ! gamma-dependent Gaussian lobe in t_c.
6028         sigtc=3*polthet(3,it)
6029         do j=2,1,-1
6030           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6031         enddo
6032         sigtc=sig*sigtc
6033 ! Set the parameters of both Gaussian lobes of the distribution.
6034 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6035         fac=sig*sig+sigc0(it)
6036         sigcsq=fac+fac
6037         sigc=1.0D0/sigcsq
6038 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6039         sigsqtc=-4.0D0*sigcsq*sigtc
6040 !       print *,i,sig,sigtc,sigsqtc
6041 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
6042         sigtc=-sigtc/(fac*fac)
6043 ! Following variable is sigma(t_c)**(-2)
6044         sigcsq=sigcsq*sigcsq
6045         sig0i=sig0(it)
6046         sig0inv=1.0D0/sig0i**2
6047         delthec=thetai-thet_pred_mean
6048         delthe0=thetai-theta0i
6049         term1=-0.5D0*sigcsq*delthec*delthec
6050         term2=-0.5D0*sig0inv*delthe0*delthe0
6051 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6052 ! NaNs in taking the logarithm. We extract the largest exponent which is added
6053 ! to the energy (this being the log of the distribution) at the end of energy
6054 ! term evaluation for this virtual-bond angle.
6055         if (term1.gt.term2) then
6056           termm=term1
6057           term2=dexp(term2-termm)
6058           term1=1.0d0
6059         else
6060           termm=term2
6061           term1=dexp(term1-termm)
6062           term2=1.0d0
6063         endif
6064 ! The ratio between the gamma-independent and gamma-dependent lobes of
6065 ! the distribution is a Gaussian function of thet_pred_mean too.
6066         diffak=gthet(2,it)-thet_pred_mean
6067         ratak=diffak/gthet(3,it)**2
6068         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6069 ! Let's differentiate it in thet_pred_mean NOW.
6070         aktc=ak*ratak
6071 ! Now put together the distribution terms to make complete distribution.
6072         termexp=term1+ak*term2
6073         termpre=sigc+ak*sig0i
6074 ! Contribution of the bending energy from this theta is just the -log of
6075 ! the sum of the contributions from the two lobes and the pre-exponential
6076 ! factor. Simple enough, isn't it?
6077         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6078 ! NOW the derivatives!!!
6079 ! 6/6/97 Take into account the deformation.
6080         E_theta=(delthec*sigcsq*term1 &
6081              +ak*delthe0*sig0inv*term2)/termexp
6082         E_tc=((sigtc+aktc*sig0i)/termpre &
6083             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
6084              aktc*term2)/termexp)
6085       return
6086       end subroutine theteng
6087 #else
6088 !-----------------------------------------------------------------------------
6089       subroutine ebend(etheta)
6090 !
6091 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6092 ! angles gamma and its derivatives in consecutive thetas and gammas.
6093 ! ab initio-derived potentials from
6094 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6095 !
6096 !      implicit real*8 (a-h,o-z)
6097 !      include 'DIMENSIONS'
6098 !      include 'COMMON.LOCAL'
6099 !      include 'COMMON.GEO'
6100 !      include 'COMMON.INTERACT'
6101 !      include 'COMMON.DERIV'
6102 !      include 'COMMON.VAR'
6103 !      include 'COMMON.CHAIN'
6104 !      include 'COMMON.IOUNITS'
6105 !      include 'COMMON.NAMES'
6106 !      include 'COMMON.FFIELD'
6107 !      include 'COMMON.CONTROL'
6108       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
6109       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
6110       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
6111       logical :: lprn=.false., lprn1=.false.
6112 !el local variables
6113       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
6114       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
6115       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
6116 ! local variables for constrains
6117       real(kind=8) :: difi,thetiii
6118        integer itheta
6119 !      write(iout,*) "in ebend",ithet_start,ithet_end
6120       call flush(iout)
6121       etheta=0.0D0
6122       do i=ithet_start,ithet_end
6123         if (itype(i-1,1).eq.ntyp1) cycle
6124         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
6125         if (iabs(itype(i+1,1)).eq.20) iblock=2
6126         if (iabs(itype(i+1,1)).ne.20) iblock=1
6127         dethetai=0.0d0
6128         dephii=0.0d0
6129         dephii1=0.0d0
6130         theti2=0.5d0*theta(i)
6131         ityp2=ithetyp((itype(i-1,1)))
6132         do k=1,nntheterm
6133           coskt(k)=dcos(k*theti2)
6134           sinkt(k)=dsin(k*theti2)
6135         enddo
6136         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
6137 #ifdef OSF
6138           phii=phi(i)
6139           if (phii.ne.phii) phii=150.0
6140 #else
6141           phii=phi(i)
6142 #endif
6143           ityp1=ithetyp((itype(i-2,1)))
6144 ! propagation of chirality for glycine type
6145           do k=1,nsingle
6146             cosph1(k)=dcos(k*phii)
6147             sinph1(k)=dsin(k*phii)
6148           enddo
6149         else
6150           phii=0.0d0
6151           ityp1=ithetyp(itype(i-2,1))
6152           do k=1,nsingle
6153             cosph1(k)=0.0d0
6154             sinph1(k)=0.0d0
6155           enddo
6156         endif
6157         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
6158 #ifdef OSF
6159           phii1=phi(i+1)
6160           if (phii1.ne.phii1) phii1=150.0
6161           phii1=pinorm(phii1)
6162 #else
6163           phii1=phi(i+1)
6164 #endif
6165           ityp3=ithetyp((itype(i,1)))
6166           do k=1,nsingle
6167             cosph2(k)=dcos(k*phii1)
6168             sinph2(k)=dsin(k*phii1)
6169           enddo
6170         else
6171           phii1=0.0d0
6172           ityp3=ithetyp(itype(i,1))
6173           do k=1,nsingle
6174             cosph2(k)=0.0d0
6175             sinph2(k)=0.0d0
6176           enddo
6177         endif
6178         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6179         do k=1,ndouble
6180           do l=1,k-1
6181             ccl=cosph1(l)*cosph2(k-l)
6182             ssl=sinph1(l)*sinph2(k-l)
6183             scl=sinph1(l)*cosph2(k-l)
6184             csl=cosph1(l)*sinph2(k-l)
6185             cosph1ph2(l,k)=ccl-ssl
6186             cosph1ph2(k,l)=ccl+ssl
6187             sinph1ph2(l,k)=scl+csl
6188             sinph1ph2(k,l)=scl-csl
6189           enddo
6190         enddo
6191         if (lprn) then
6192         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
6193           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6194         write (iout,*) "coskt and sinkt"
6195         do k=1,nntheterm
6196           write (iout,*) k,coskt(k),sinkt(k)
6197         enddo
6198         endif
6199         do k=1,ntheterm
6200           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6201           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
6202             *coskt(k)
6203           if (lprn) &
6204           write (iout,*) "k",k,&
6205            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
6206            " ethetai",ethetai
6207         enddo
6208         if (lprn) then
6209         write (iout,*) "cosph and sinph"
6210         do k=1,nsingle
6211           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6212         enddo
6213         write (iout,*) "cosph1ph2 and sinph2ph2"
6214         do k=2,ndouble
6215           do l=1,k-1
6216             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
6217                sinph1ph2(l,k),sinph1ph2(k,l)
6218           enddo
6219         enddo
6220         write(iout,*) "ethetai",ethetai
6221         endif
6222         do m=1,ntheterm2
6223           do k=1,nsingle
6224             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
6225                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
6226                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
6227                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6228             ethetai=ethetai+sinkt(m)*aux
6229             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6230             dephii=dephii+k*sinkt(m)* &
6231                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
6232                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6233             dephii1=dephii1+k*sinkt(m)* &
6234                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
6235                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6236             if (lprn) &
6237             write (iout,*) "m",m," k",k," bbthet", &
6238                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
6239                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
6240                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
6241                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6242           enddo
6243         enddo
6244         if (lprn) &
6245         write(iout,*) "ethetai",ethetai
6246         do m=1,ntheterm3
6247           do k=2,ndouble
6248             do l=1,k-1
6249               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6250                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
6251                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6252                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6253               ethetai=ethetai+sinkt(m)*aux
6254               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6255               dephii=dephii+l*sinkt(m)* &
6256                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
6257                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6258                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6259                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6260               dephii1=dephii1+(k-l)*sinkt(m)* &
6261                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6262                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6263                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
6264                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6265               if (lprn) then
6266               write (iout,*) "m",m," k",k," l",l," ffthet",&
6267                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6268                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
6269                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6270                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
6271                   " ethetai",ethetai
6272               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
6273                   cosph1ph2(k,l)*sinkt(m),&
6274                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6275               endif
6276             enddo
6277           enddo
6278         enddo
6279 10      continue
6280 !        lprn1=.true.
6281         if (lprn1) &
6282           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
6283          i,theta(i)*rad2deg,phii*rad2deg,&
6284          phii1*rad2deg,ethetai
6285 !        lprn1=.false.
6286         etheta=etheta+ethetai
6287         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6288                                     'ebend',i,ethetai
6289         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6290         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6291         gloc(nphi+i-2,icg)=wang*dethetai
6292       enddo
6293 !-----------thete constrains
6294 !      if (tor_mode.ne.2) then
6295
6296       return
6297       end subroutine ebend
6298 #endif
6299 #ifdef CRYST_SC
6300 !-----------------------------------------------------------------------------
6301       subroutine esc(escloc)
6302 ! Calculate the local energy of a side chain and its derivatives in the
6303 ! corresponding virtual-bond valence angles THETA and the spherical angles
6304 ! ALPHA and OMEGA.
6305 !
6306       use comm_sccalc
6307 !      implicit real*8 (a-h,o-z)
6308 !      include 'DIMENSIONS'
6309 !      include 'COMMON.GEO'
6310 !      include 'COMMON.LOCAL'
6311 !      include 'COMMON.VAR'
6312 !      include 'COMMON.INTERACT'
6313 !      include 'COMMON.DERIV'
6314 !      include 'COMMON.CHAIN'
6315 !      include 'COMMON.IOUNITS'
6316 !      include 'COMMON.NAMES'
6317 !      include 'COMMON.FFIELD'
6318 !      include 'COMMON.CONTROL'
6319       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
6320          ddersc0,ddummy,xtemp,temp
6321 !el      real(kind=8) :: time11,time12,time112,theti
6322       real(kind=8) :: escloc,delta
6323 !el      integer :: it,nlobit
6324 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6325 !el local variables
6326       integer :: i,k
6327       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
6328        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6329       delta=0.02d0*pi
6330       escloc=0.0D0
6331 !     write (iout,'(a)') 'ESC'
6332       do i=loc_start,loc_end
6333         it=itype(i,1)
6334         if (it.eq.ntyp1) cycle
6335         if (it.eq.10) goto 1
6336         nlobit=nlob(iabs(it))
6337 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
6338 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6339         theti=theta(i+1)-pipol
6340         x(1)=dtan(theti)
6341         x(2)=alph(i)
6342         x(3)=omeg(i)
6343
6344         if (x(2).gt.pi-delta) then
6345           xtemp(1)=x(1)
6346           xtemp(2)=pi-delta
6347           xtemp(3)=x(3)
6348           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6349           xtemp(2)=pi
6350           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6351           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
6352               escloci,dersc(2))
6353           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6354               ddersc0(1),dersc(1))
6355           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
6356               ddersc0(3),dersc(3))
6357           xtemp(2)=pi-delta
6358           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6359           xtemp(2)=pi
6360           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6361           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
6362                   dersc0(2),esclocbi,dersc02)
6363           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6364                   dersc12,dersc01)
6365           call splinthet(x(2),0.5d0*delta,ss,ssd)
6366           dersc0(1)=dersc01
6367           dersc0(2)=dersc02
6368           dersc0(3)=0.0d0
6369           do k=1,3
6370             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6371           enddo
6372           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6373 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6374 !    &             esclocbi,ss,ssd
6375           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6376 !         escloci=esclocbi
6377 !         write (iout,*) escloci
6378         else if (x(2).lt.delta) then
6379           xtemp(1)=x(1)
6380           xtemp(2)=delta
6381           xtemp(3)=x(3)
6382           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6383           xtemp(2)=0.0d0
6384           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6385           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
6386               escloci,dersc(2))
6387           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6388               ddersc0(1),dersc(1))
6389           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6390               ddersc0(3),dersc(3))
6391           xtemp(2)=delta
6392           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6393           xtemp(2)=0.0d0
6394           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6395           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6396                   dersc0(2),esclocbi,dersc02)
6397           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6398                   dersc12,dersc01)
6399           dersc0(1)=dersc01
6400           dersc0(2)=dersc02
6401           dersc0(3)=0.0d0
6402           call splinthet(x(2),0.5d0*delta,ss,ssd)
6403           do k=1,3
6404             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6405           enddo
6406           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6407 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6408 !    &             esclocbi,ss,ssd
6409           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6410 !         write (iout,*) escloci
6411         else
6412           call enesc(x,escloci,dersc,ddummy,.false.)
6413         endif
6414
6415         escloc=escloc+escloci
6416         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6417            'escloc',i,escloci
6418 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6419
6420         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6421          wscloc*dersc(1)
6422         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6423         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6424     1   continue
6425       enddo
6426       return
6427       end subroutine esc
6428 !-----------------------------------------------------------------------------
6429       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6430
6431       use comm_sccalc
6432 !      implicit real*8 (a-h,o-z)
6433 !      include 'DIMENSIONS'
6434 !      include 'COMMON.GEO'
6435 !      include 'COMMON.LOCAL'
6436 !      include 'COMMON.IOUNITS'
6437 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6438       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6439       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6440       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6441       real(kind=8) :: escloci
6442       logical :: mixed
6443 !el local variables
6444       integer :: j,iii,l,k !el,it,nlobit
6445       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6446 !el       time11,time12,time112
6447 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6448         escloc_i=0.0D0
6449         do j=1,3
6450           dersc(j)=0.0D0
6451           if (mixed) ddersc(j)=0.0d0
6452         enddo
6453         x3=x(3)
6454
6455 ! Because of periodicity of the dependence of the SC energy in omega we have
6456 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6457 ! To avoid underflows, first compute & store the exponents.
6458
6459         do iii=-1,1
6460
6461           x(3)=x3+iii*dwapi
6462
6463           do j=1,nlobit
6464             do k=1,3
6465               z(k)=x(k)-censc(k,j,it)
6466             enddo
6467             do k=1,3
6468               Axk=0.0D0
6469               do l=1,3
6470                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6471               enddo
6472               Ax(k,j,iii)=Axk
6473             enddo
6474             expfac=0.0D0
6475             do k=1,3
6476               expfac=expfac+Ax(k,j,iii)*z(k)
6477             enddo
6478             contr(j,iii)=expfac
6479           enddo ! j
6480
6481         enddo ! iii
6482
6483         x(3)=x3
6484 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6485 ! subsequent NaNs and INFs in energy calculation.
6486 ! Find the largest exponent
6487         emin=contr(1,-1)
6488         do iii=-1,1
6489           do j=1,nlobit
6490             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6491           enddo
6492         enddo
6493         emin=0.5D0*emin
6494 !d      print *,'it=',it,' emin=',emin
6495
6496 ! Compute the contribution to SC energy and derivatives
6497         do iii=-1,1
6498
6499           do j=1,nlobit
6500 #ifdef OSF
6501             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6502             if(adexp.ne.adexp) adexp=1.0
6503             expfac=dexp(adexp)
6504 #else
6505             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6506 #endif
6507 !d          print *,'j=',j,' expfac=',expfac
6508             escloc_i=escloc_i+expfac
6509             do k=1,3
6510               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6511             enddo
6512             if (mixed) then
6513               do k=1,3,2
6514                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6515                   +gaussc(k,2,j,it))*expfac
6516               enddo
6517             endif
6518           enddo
6519
6520         enddo ! iii
6521
6522         dersc(1)=dersc(1)/cos(theti)**2
6523         ddersc(1)=ddersc(1)/cos(theti)**2
6524         ddersc(3)=ddersc(3)
6525
6526         escloci=-(dlog(escloc_i)-emin)
6527         do j=1,3
6528           dersc(j)=dersc(j)/escloc_i
6529         enddo
6530         if (mixed) then
6531           do j=1,3,2
6532             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6533           enddo
6534         endif
6535       return
6536       end subroutine enesc
6537 !-----------------------------------------------------------------------------
6538       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6539
6540       use comm_sccalc
6541 !      implicit real*8 (a-h,o-z)
6542 !      include 'DIMENSIONS'
6543 !      include 'COMMON.GEO'
6544 !      include 'COMMON.LOCAL'
6545 !      include 'COMMON.IOUNITS'
6546 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6547       real(kind=8),dimension(3) :: x,z,dersc
6548       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6549       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6550       real(kind=8) :: escloci,dersc12,emin
6551       logical :: mixed
6552 !el local varables
6553       integer :: j,k,l !el,it,nlobit
6554       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6555
6556       escloc_i=0.0D0
6557
6558       do j=1,3
6559         dersc(j)=0.0D0
6560       enddo
6561
6562       do j=1,nlobit
6563         do k=1,2
6564           z(k)=x(k)-censc(k,j,it)
6565         enddo
6566         z(3)=dwapi
6567         do k=1,3
6568           Axk=0.0D0
6569           do l=1,3
6570             Axk=Axk+gaussc(l,k,j,it)*z(l)
6571           enddo
6572           Ax(k,j)=Axk
6573         enddo
6574         expfac=0.0D0
6575         do k=1,3
6576           expfac=expfac+Ax(k,j)*z(k)
6577         enddo
6578         contr(j)=expfac
6579       enddo ! j
6580
6581 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6582 ! subsequent NaNs and INFs in energy calculation.
6583 ! Find the largest exponent
6584       emin=contr(1)
6585       do j=1,nlobit
6586         if (emin.gt.contr(j)) emin=contr(j)
6587       enddo
6588       emin=0.5D0*emin
6589
6590 ! Compute the contribution to SC energy and derivatives
6591
6592       dersc12=0.0d0
6593       do j=1,nlobit
6594         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6595         escloc_i=escloc_i+expfac
6596         do k=1,2
6597           dersc(k)=dersc(k)+Ax(k,j)*expfac
6598         enddo
6599         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6600                   +gaussc(1,2,j,it))*expfac
6601         dersc(3)=0.0d0
6602       enddo
6603
6604       dersc(1)=dersc(1)/cos(theti)**2
6605       dersc12=dersc12/cos(theti)**2
6606       escloci=-(dlog(escloc_i)-emin)
6607       do j=1,2
6608         dersc(j)=dersc(j)/escloc_i
6609       enddo
6610       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6611       return
6612       end subroutine enesc_bound
6613 #else
6614 !-----------------------------------------------------------------------------
6615       subroutine esc(escloc)
6616 ! Calculate the local energy of a side chain and its derivatives in the
6617 ! corresponding virtual-bond valence angles THETA and the spherical angles
6618 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6619 ! added by Urszula Kozlowska. 07/11/2007
6620 !
6621       use comm_sccalc
6622 !      implicit real*8 (a-h,o-z)
6623 !      include 'DIMENSIONS'
6624 !      include 'COMMON.GEO'
6625 !      include 'COMMON.LOCAL'
6626 !      include 'COMMON.VAR'
6627 !      include 'COMMON.SCROT'
6628 !      include 'COMMON.INTERACT'
6629 !      include 'COMMON.DERIV'
6630 !      include 'COMMON.CHAIN'
6631 !      include 'COMMON.IOUNITS'
6632 !      include 'COMMON.NAMES'
6633 !      include 'COMMON.FFIELD'
6634 !      include 'COMMON.CONTROL'
6635 !      include 'COMMON.VECTORS'
6636       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6637       real(kind=8),dimension(65) :: x
6638       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6639          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6640       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6641       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6642          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6643 !el local variables
6644       integer :: i,j,k !el,it,nlobit
6645       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6646 !el      real(kind=8) :: time11,time12,time112,theti
6647 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6648       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6649                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6650                    sumene1x,sumene2x,sumene3x,sumene4x,&
6651                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6652                    cosfac2xx,sinfac2yy
6653 #ifdef DEBUG
6654       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6655                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6656                    de_dt_num
6657 #endif
6658 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6659
6660       delta=0.02d0*pi
6661       escloc=0.0D0
6662       do i=loc_start,loc_end
6663         if (itype(i,1).eq.ntyp1) cycle
6664         costtab(i+1) =dcos(theta(i+1))
6665         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6666         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6667         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6668         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6669         cosfac=dsqrt(cosfac2)
6670         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6671         sinfac=dsqrt(sinfac2)
6672         it=iabs(itype(i,1))
6673         if (it.eq.10) goto 1
6674 !
6675 !  Compute the axes of tghe local cartesian coordinates system; store in
6676 !   x_prime, y_prime and z_prime
6677 !
6678         do j=1,3
6679           x_prime(j) = 0.00
6680           y_prime(j) = 0.00
6681           z_prime(j) = 0.00
6682         enddo
6683 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6684 !     &   dc_norm(3,i+nres)
6685         do j = 1,3
6686           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6687           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6688         enddo
6689         do j = 1,3
6690           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6691         enddo
6692 !       write (2,*) "i",i
6693 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6694 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6695 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6696 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6697 !      & " xy",scalar(x_prime(1),y_prime(1)),
6698 !      & " xz",scalar(x_prime(1),z_prime(1)),
6699 !      & " yy",scalar(y_prime(1),y_prime(1)),
6700 !      & " yz",scalar(y_prime(1),z_prime(1)),
6701 !      & " zz",scalar(z_prime(1),z_prime(1))
6702 !
6703 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6704 ! to local coordinate system. Store in xx, yy, zz.
6705 !
6706         xx=0.0d0
6707         yy=0.0d0
6708         zz=0.0d0
6709         do j = 1,3
6710           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6711           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6712           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6713         enddo
6714
6715         xxtab(i)=xx
6716         yytab(i)=yy
6717         zztab(i)=zz
6718 !
6719 ! Compute the energy of the ith side cbain
6720 !
6721 !        write (2,*) "xx",xx," yy",yy," zz",zz
6722         it=iabs(itype(i,1))
6723         do j = 1,65
6724           x(j) = sc_parmin(j,it)
6725         enddo
6726 #ifdef CHECK_COORD
6727 !c diagnostics - remove later
6728         xx1 = dcos(alph(2))
6729         yy1 = dsin(alph(2))*dcos(omeg(2))
6730         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6731         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6732           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6733           xx1,yy1,zz1
6734 !,"  --- ", xx_w,yy_w,zz_w
6735 ! end diagnostics
6736 #endif
6737         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6738          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6739          + x(10)*yy*zz
6740         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6741          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6742          + x(20)*yy*zz
6743         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6744          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6745          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6746          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6747          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6748          +x(40)*xx*yy*zz
6749         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6750          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6751          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6752          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6753          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6754          +x(60)*xx*yy*zz
6755         dsc_i   = 0.743d0+x(61)
6756         dp2_i   = 1.9d0+x(62)
6757         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6758                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6759         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6760                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6761         s1=(1+x(63))/(0.1d0 + dscp1)
6762         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6763         s2=(1+x(65))/(0.1d0 + dscp2)
6764         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6765         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6766       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6767 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6768 !     &   sumene4,
6769 !     &   dscp1,dscp2,sumene
6770 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6771         escloc = escloc + sumene
6772        if (energy_dec) write (2,*) "i",i," itype",itype(i,1)," it",it, &
6773         " escloc",sumene,escloc,it,itype(i,1)
6774 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6775 !     & ,zz,xx,yy
6776 !#define DEBUG
6777 #ifdef DEBUG
6778 !
6779 ! This section to check the numerical derivatives of the energy of ith side
6780 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6781 ! #define DEBUG in the code to turn it on.
6782 !
6783         write (2,*) "sumene               =",sumene
6784         aincr=1.0d-7
6785         xxsave=xx
6786         xx=xx+aincr
6787         write (2,*) xx,yy,zz
6788         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6789         de_dxx_num=(sumenep-sumene)/aincr
6790         xx=xxsave
6791         write (2,*) "xx+ sumene from enesc=",sumenep
6792         yysave=yy
6793         yy=yy+aincr
6794         write (2,*) xx,yy,zz
6795         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6796         de_dyy_num=(sumenep-sumene)/aincr
6797         yy=yysave
6798         write (2,*) "yy+ sumene from enesc=",sumenep
6799         zzsave=zz
6800         zz=zz+aincr
6801         write (2,*) xx,yy,zz
6802         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6803         de_dzz_num=(sumenep-sumene)/aincr
6804         zz=zzsave
6805         write (2,*) "zz+ sumene from enesc=",sumenep
6806         costsave=cost2tab(i+1)
6807         sintsave=sint2tab(i+1)
6808         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6809         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6810         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6811         de_dt_num=(sumenep-sumene)/aincr
6812         write (2,*) " t+ sumene from enesc=",sumenep
6813         cost2tab(i+1)=costsave
6814         sint2tab(i+1)=sintsave
6815 ! End of diagnostics section.
6816 #endif
6817 !
6818 ! Compute the gradient of esc
6819 !
6820 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6821         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6822         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6823         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6824         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6825         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6826         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6827         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6828         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6829         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6830            *(pom_s1/dscp1+pom_s16*dscp1**4)
6831         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6832            *(pom_s2/dscp2+pom_s26*dscp2**4)
6833         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6834         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6835         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6836         +x(40)*yy*zz
6837         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6838         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6839         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6840         +x(60)*yy*zz
6841         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6842               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6843               +(pom1+pom2)*pom_dx
6844 #ifdef DEBUG
6845         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6846 #endif
6847 !
6848         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6849         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6850         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6851         +x(40)*xx*zz
6852         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6853         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6854         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6855         +x(59)*zz**2 +x(60)*xx*zz
6856         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6857               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6858               +(pom1-pom2)*pom_dy
6859 #ifdef DEBUG
6860         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6861 #endif
6862 !
6863         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6864         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6865         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6866         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6867         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6868         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6869         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6870         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6871 #ifdef DEBUG
6872         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
6873 #endif
6874 !
6875         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6876         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6877         +pom1*pom_dt1+pom2*pom_dt2
6878 #ifdef DEBUG
6879         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
6880 #endif
6881 !
6882 !
6883        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6884        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6885        cosfac2xx=cosfac2*xx
6886        sinfac2yy=sinfac2*yy
6887        do k = 1,3
6888          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6889             vbld_inv(i+1)
6890          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6891             vbld_inv(i)
6892          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6893          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6894 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6895 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6896 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6897 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6898          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6899          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6900          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6901          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6902          dZZ_Ci1(k)=0.0d0
6903          dZZ_Ci(k)=0.0d0
6904          do j=1,3
6905            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6906            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6907            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6908            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6909          enddo
6910
6911          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6912          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6913          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6914          (z_prime(k)-zz*dC_norm(k,i+nres))
6915 !
6916          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6917          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6918        enddo
6919
6920        do k=1,3
6921          dXX_Ctab(k,i)=dXX_Ci(k)
6922          dXX_C1tab(k,i)=dXX_Ci1(k)
6923          dYY_Ctab(k,i)=dYY_Ci(k)
6924          dYY_C1tab(k,i)=dYY_Ci1(k)
6925          dZZ_Ctab(k,i)=dZZ_Ci(k)
6926          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6927          dXX_XYZtab(k,i)=dXX_XYZ(k)
6928          dYY_XYZtab(k,i)=dYY_XYZ(k)
6929          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6930        enddo
6931
6932        do k = 1,3
6933 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6934 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6935 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6936 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6937 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6938 !     &    dt_dci(k)
6939 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6940 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6941          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6942           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6943          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6944           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6945          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6946           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6947        enddo
6948 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6949 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6950
6951 ! to check gradient call subroutine check_grad
6952
6953     1 continue
6954       enddo
6955       return
6956       end subroutine esc
6957 !-----------------------------------------------------------------------------
6958       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6959 !      implicit none
6960       real(kind=8),dimension(65) :: x
6961       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6962         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6963
6964       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6965         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6966         + x(10)*yy*zz
6967       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6968         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6969         + x(20)*yy*zz
6970       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6971         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6972         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6973         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6974         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6975         +x(40)*xx*yy*zz
6976       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6977         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6978         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6979         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6980         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6981         +x(60)*xx*yy*zz
6982       dsc_i   = 0.743d0+x(61)
6983       dp2_i   = 1.9d0+x(62)
6984       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6985                 *(xx*cost2+yy*sint2))
6986       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6987                 *(xx*cost2-yy*sint2))
6988       s1=(1+x(63))/(0.1d0 + dscp1)
6989       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6990       s2=(1+x(65))/(0.1d0 + dscp2)
6991       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6992       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
6993        + (sumene4*cost2 +sumene2)*(s2+s2_6)
6994       enesc=sumene
6995       return
6996       end function enesc
6997 #endif
6998 !-----------------------------------------------------------------------------
6999       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7000 !
7001 ! This procedure calculates two-body contact function g(rij) and its derivative:
7002 !
7003 !           eps0ij                                     !       x < -1
7004 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7005 !            0                                         !       x > 1
7006 !
7007 ! where x=(rij-r0ij)/delta
7008 !
7009 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7010 !
7011 !      implicit none
7012       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
7013       real(kind=8) :: x,x2,x4,delta
7014 !     delta=0.02D0*r0ij
7015 !      delta=0.2D0*r0ij
7016       x=(rij-r0ij)/delta
7017       if (x.lt.-1.0D0) then
7018         fcont=eps0ij
7019         fprimcont=0.0D0
7020       else if (x.le.1.0D0) then
7021         x2=x*x
7022         x4=x2*x2
7023         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7024         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7025       else
7026         fcont=0.0D0
7027         fprimcont=0.0D0
7028       endif
7029       return
7030       end subroutine gcont
7031 !-----------------------------------------------------------------------------
7032       subroutine splinthet(theti,delta,ss,ssder)
7033 !      implicit real*8 (a-h,o-z)
7034 !      include 'DIMENSIONS'
7035 !      include 'COMMON.VAR'
7036 !      include 'COMMON.GEO'
7037       real(kind=8) :: theti,delta,ss,ssder
7038       real(kind=8) :: thetup,thetlow
7039       thetup=pi-delta
7040       thetlow=delta
7041       if (theti.gt.pipol) then
7042         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7043       else
7044         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7045         ssder=-ssder
7046       endif
7047       return
7048       end subroutine splinthet
7049 !-----------------------------------------------------------------------------
7050       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7051 !      implicit none
7052       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
7053       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7054       a1=fprim0*delta/(f1-f0)
7055       a2=3.0d0-2.0d0*a1
7056       a3=a1-2.0d0
7057       ksi=(x-x0)/delta
7058       ksi2=ksi*ksi
7059       ksi3=ksi2*ksi
7060       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7061       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7062       return
7063       end subroutine spline1
7064 !-----------------------------------------------------------------------------
7065       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7066 !      implicit none
7067       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
7068       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7069       ksi=(x-x0)/delta
7070       ksi2=ksi*ksi
7071       ksi3=ksi2*ksi
7072       a1=fprim0x*delta
7073       a2=3*(f1x-f0x)-2*fprim0x*delta
7074       a3=fprim0x*delta-2*(f1x-f0x)
7075       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7076       return
7077       end subroutine spline2
7078 !-----------------------------------------------------------------------------
7079 #ifdef CRYST_TOR
7080 !-----------------------------------------------------------------------------
7081       subroutine etor(etors,edihcnstr)
7082 !      implicit real*8 (a-h,o-z)
7083 !      include 'DIMENSIONS'
7084 !      include 'COMMON.VAR'
7085 !      include 'COMMON.GEO'
7086 !      include 'COMMON.LOCAL'
7087 !      include 'COMMON.TORSION'
7088 !      include 'COMMON.INTERACT'
7089 !      include 'COMMON.DERIV'
7090 !      include 'COMMON.CHAIN'
7091 !      include 'COMMON.NAMES'
7092 !      include 'COMMON.IOUNITS'
7093 !      include 'COMMON.FFIELD'
7094 !      include 'COMMON.TORCNSTR'
7095 !      include 'COMMON.CONTROL'
7096       real(kind=8) :: etors,edihcnstr
7097       logical :: lprn
7098 !el local variables
7099       integer :: i,j,
7100       real(kind=8) :: phii,fac,etors_ii
7101
7102 ! Set lprn=.true. for debugging
7103       lprn=.false.
7104 !      lprn=.true.
7105       etors=0.0D0
7106       do i=iphi_start,iphi_end
7107       etors_ii=0.0D0
7108         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7109             .or. itype(i,1).eq.ntyp1) cycle
7110         itori=itortyp(itype(i-2,1))
7111         itori1=itortyp(itype(i-1,1))
7112         phii=phi(i)
7113         gloci=0.0D0
7114 ! Proline-Proline pair is a special case...
7115         if (itori.eq.3 .and. itori1.eq.3) then
7116           if (phii.gt.-dwapi3) then
7117             cosphi=dcos(3*phii)
7118             fac=1.0D0/(1.0D0-cosphi)
7119             etorsi=v1(1,3,3)*fac
7120             etorsi=etorsi+etorsi
7121             etors=etors+etorsi-v1(1,3,3)
7122             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7123             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7124           endif
7125           do j=1,3
7126             v1ij=v1(j+1,itori,itori1)
7127             v2ij=v2(j+1,itori,itori1)
7128             cosphi=dcos(j*phii)
7129             sinphi=dsin(j*phii)
7130             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7131             if (energy_dec) etors_ii=etors_ii+ &
7132                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7133             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7134           enddo
7135         else
7136           do j=1,nterm_old
7137             v1ij=v1(j,itori,itori1)
7138             v2ij=v2(j,itori,itori1)
7139             cosphi=dcos(j*phii)
7140             sinphi=dsin(j*phii)
7141             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7142             if (energy_dec) etors_ii=etors_ii+ &
7143                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7144             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7145           enddo
7146         endif
7147         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7148              'etor',i,etors_ii
7149         if (lprn) &
7150         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7151         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7152         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7153         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7154 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7155       enddo
7156 ! 6/20/98 - dihedral angle constraints
7157       edihcnstr=0.0d0
7158       do i=1,ndih_constr
7159         itori=idih_constr(i)
7160         phii=phi(itori)
7161         difi=phii-phi0(i)
7162         if (difi.gt.drange(i)) then
7163           difi=difi-drange(i)
7164           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7165           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7166         else if (difi.lt.-drange(i)) then
7167           difi=difi+drange(i)
7168           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7169           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7170         endif
7171 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7172 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7173       enddo
7174 !      write (iout,*) 'edihcnstr',edihcnstr
7175       return
7176       end subroutine etor
7177 !-----------------------------------------------------------------------------
7178       subroutine etor_d(etors_d)
7179       real(kind=8) :: etors_d
7180       etors_d=0.0d0
7181       return
7182       end subroutine etor_d
7183 #else
7184 !-----------------------------------------------------------------------------
7185       subroutine etor(etors)
7186 !      implicit real*8 (a-h,o-z)
7187 !      include 'DIMENSIONS'
7188 !      include 'COMMON.VAR'
7189 !      include 'COMMON.GEO'
7190 !      include 'COMMON.LOCAL'
7191 !      include 'COMMON.TORSION'
7192 !      include 'COMMON.INTERACT'
7193 !      include 'COMMON.DERIV'
7194 !      include 'COMMON.CHAIN'
7195 !      include 'COMMON.NAMES'
7196 !      include 'COMMON.IOUNITS'
7197 !      include 'COMMON.FFIELD'
7198 !      include 'COMMON.TORCNSTR'
7199 !      include 'COMMON.CONTROL'
7200       real(kind=8) :: etors,edihcnstr
7201       logical :: lprn
7202 !el local variables
7203       integer :: i,j,iblock,itori,itori1
7204       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7205                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
7206 ! Set lprn=.true. for debugging
7207       lprn=.false.
7208 !     lprn=.true.
7209       etors=0.0D0
7210       do i=iphi_start,iphi_end
7211         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7212              .or. itype(i-3,1).eq.ntyp1 &
7213              .or. itype(i,1).eq.ntyp1) cycle
7214         etors_ii=0.0D0
7215          if (iabs(itype(i,1)).eq.20) then
7216          iblock=2
7217          else
7218          iblock=1
7219          endif
7220         itori=itortyp(itype(i-2,1))
7221         itori1=itortyp(itype(i-1,1))
7222         phii=phi(i)
7223         gloci=0.0D0
7224 ! Regular cosine and sine terms
7225         do j=1,nterm(itori,itori1,iblock)
7226           v1ij=v1(j,itori,itori1,iblock)
7227           v2ij=v2(j,itori,itori1,iblock)
7228           cosphi=dcos(j*phii)
7229           sinphi=dsin(j*phii)
7230           etors=etors+v1ij*cosphi+v2ij*sinphi
7231           if (energy_dec) etors_ii=etors_ii+ &
7232                      v1ij*cosphi+v2ij*sinphi
7233           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7234         enddo
7235 ! Lorentz terms
7236 !                         v1
7237 !  E = SUM ----------------------------------- - v1
7238 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7239 !
7240         cosphi=dcos(0.5d0*phii)
7241         sinphi=dsin(0.5d0*phii)
7242         do j=1,nlor(itori,itori1,iblock)
7243           vl1ij=vlor1(j,itori,itori1)
7244           vl2ij=vlor2(j,itori,itori1)
7245           vl3ij=vlor3(j,itori,itori1)
7246           pom=vl2ij*cosphi+vl3ij*sinphi
7247           pom1=1.0d0/(pom*pom+1.0d0)
7248           etors=etors+vl1ij*pom1
7249           if (energy_dec) etors_ii=etors_ii+ &
7250                      vl1ij*pom1
7251           pom=-pom*pom1*pom1
7252           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7253         enddo
7254 ! Subtract the constant term
7255         etors=etors-v0(itori,itori1,iblock)
7256           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7257                'etor',i,etors_ii-v0(itori,itori1,iblock)
7258         if (lprn) &
7259         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7260         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7261         (v1(j,itori,itori1,iblock),j=1,6),&
7262         (v2(j,itori,itori1,iblock),j=1,6)
7263         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7264 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7265       enddo
7266 ! 6/20/98 - dihedral angle constraints
7267       return
7268       end subroutine etor
7269 !C The rigorous attempt to derive energy function
7270 !-------------------------------------------------------------------------------------------
7271       subroutine etor_kcc(etors)
7272       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7273       real(kind=8) :: etors,glocig,glocit1,glocit2,sinthet1,&
7274        sinthet2,costhet1,costhet2,sint1t2,sint1t2n,phii,sinphi,cosphi,&
7275        sint1t2n1,sumvalc,gradvalct1,gradvalct2,sumvals,gradvalst1,&
7276        gradvalst2,etori
7277       logical lprn
7278       integer :: i,j,itori,itori1,nval,k,l
7279
7280       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7281       etors=0.0D0
7282       do i=iphi_start,iphi_end
7283 !C ANY TWO ARE DUMMY ATOMS in row CYCLE
7284 !c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7285 !c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7286 !c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7287         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7288            .or. itype(i,1).eq.ntyp1 .or. itype(i-3,1).eq.ntyp1) cycle
7289         itori=itortyp(itype(i-2,1))
7290         itori1=itortyp(itype(i-1,1))
7291         phii=phi(i)
7292         glocig=0.0D0
7293         glocit1=0.0d0
7294         glocit2=0.0d0
7295 !C to avoid multiple devision by 2
7296 !c        theti22=0.5d0*theta(i)
7297 !C theta 12 is the theta_1 /2
7298 !C theta 22 is theta_2 /2
7299 !c        theti12=0.5d0*theta(i-1)
7300 !C and appropriate sinus function
7301         sinthet1=dsin(theta(i-1))
7302         sinthet2=dsin(theta(i))
7303         costhet1=dcos(theta(i-1))
7304         costhet2=dcos(theta(i))
7305 !C to speed up lets store its mutliplication
7306         sint1t2=sinthet2*sinthet1
7307         sint1t2n=1.0d0
7308 !C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7309 !C +d_n*sin(n*gamma)) *
7310 !C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7311 !C we have two sum 1) Non-Chebyshev which is with n and gamma
7312         nval=nterm_kcc_Tb(itori,itori1)
7313         c1(0)=0.0d0
7314         c2(0)=0.0d0
7315         c1(1)=1.0d0
7316         c2(1)=1.0d0
7317         do j=2,nval
7318           c1(j)=c1(j-1)*costhet1
7319           c2(j)=c2(j-1)*costhet2
7320         enddo
7321         etori=0.0d0
7322
7323        do j=1,nterm_kcc(itori,itori1)
7324           cosphi=dcos(j*phii)
7325           sinphi=dsin(j*phii)
7326           sint1t2n1=sint1t2n
7327           sint1t2n=sint1t2n*sint1t2
7328           sumvalc=0.0d0
7329           gradvalct1=0.0d0
7330           gradvalct2=0.0d0
7331           do k=1,nval
7332             do l=1,nval
7333               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7334               gradvalct1=gradvalct1+ &
7335                 (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7336               gradvalct2=gradvalct2+ &
7337                 (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7338             enddo
7339           enddo
7340           gradvalct1=-gradvalct1*sinthet1
7341           gradvalct2=-gradvalct2*sinthet2
7342           sumvals=0.0d0
7343           gradvalst1=0.0d0
7344           gradvalst2=0.0d0
7345           do k=1,nval
7346             do l=1,nval
7347               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7348               gradvalst1=gradvalst1+ &
7349                 (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7350               gradvalst2=gradvalst2+ &
7351                 (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7352             enddo
7353           enddo
7354           gradvalst1=-gradvalst1*sinthet1
7355           gradvalst2=-gradvalst2*sinthet2
7356           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7357           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7358 !C glocig is the gradient local i site in gamma
7359           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7360 !C now gradient over theta_1
7361          glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)&
7362         +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7363          glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)&
7364         +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7365         enddo ! j
7366         etors=etors+etori
7367         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7368 !C derivative over theta1
7369         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7370 !C now derivative over theta2
7371         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7372         if (lprn) then
7373          write (iout,*) i-2,i-1,itype(i-2,1),itype(i-1,1),itori,itori1,&
7374             theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7375           write (iout,*) "c1",(c1(k),k=0,nval), &
7376          " c2",(c2(k),k=0,nval)
7377         endif
7378       enddo
7379       return
7380        end  subroutine etor_kcc
7381 !------------------------------------------------------------------------------
7382
7383         subroutine etor_constr(edihcnstr)
7384       real(kind=8) :: etors,edihcnstr
7385       logical :: lprn
7386 !el local variables
7387       integer :: i,j,iblock,itori,itori1
7388       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7389                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom,&
7390                    gaudih_i,gauder_i,s,cos_i,dexpcos_i
7391
7392       if (raw_psipred) then
7393         do i=idihconstr_start,idihconstr_end
7394           itori=idih_constr(i)
7395           phii=phi(itori)
7396           gaudih_i=vpsipred(1,i)
7397           gauder_i=0.0d0
7398           do j=1,2
7399             s = sdihed(j,i)
7400             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7401             dexpcos_i=dexp(-cos_i*cos_i)
7402             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7403           gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i)) &
7404                  *cos_i*dexpcos_i/s**2
7405           enddo
7406           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7407           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7408           if (energy_dec) &
7409           write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)') &
7410           i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),&
7411           phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),&
7412           phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,&
7413           -wdihc*dlog(gaudih_i)
7414         enddo
7415       else
7416
7417       do i=idihconstr_start,idihconstr_end
7418         itori=idih_constr(i)
7419         phii=phi(itori)
7420         difi=pinorm(phii-phi0(i))
7421         if (difi.gt.drange(i)) then
7422           difi=difi-drange(i)
7423           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7424           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7425         else if (difi.lt.-drange(i)) then
7426           difi=difi+drange(i)
7427           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7428           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7429         else
7430           difi=0.0
7431         endif
7432       enddo
7433
7434       endif
7435
7436       return
7437
7438       end subroutine etor_constr
7439 !-----------------------------------------------------------------------------
7440       subroutine etor_d(etors_d)
7441 ! 6/23/01 Compute double torsional energy
7442 !      implicit real*8 (a-h,o-z)
7443 !      include 'DIMENSIONS'
7444 !      include 'COMMON.VAR'
7445 !      include 'COMMON.GEO'
7446 !      include 'COMMON.LOCAL'
7447 !      include 'COMMON.TORSION'
7448 !      include 'COMMON.INTERACT'
7449 !      include 'COMMON.DERIV'
7450 !      include 'COMMON.CHAIN'
7451 !      include 'COMMON.NAMES'
7452 !      include 'COMMON.IOUNITS'
7453 !      include 'COMMON.FFIELD'
7454 !      include 'COMMON.TORCNSTR'
7455       real(kind=8) :: etors_d,etors_d_ii
7456       logical :: lprn
7457 !el local variables
7458       integer :: i,j,k,l,itori,itori1,itori2,iblock
7459       real(kind=8) :: phii,phii1,gloci1,gloci2,&
7460                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
7461                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
7462                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
7463 ! Set lprn=.true. for debugging
7464       lprn=.false.
7465 !     lprn=.true.
7466       etors_d=0.0D0
7467 !      write(iout,*) "a tu??"
7468       do i=iphid_start,iphid_end
7469         etors_d_ii=0.0D0
7470         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7471             .or. itype(i-3,1).eq.ntyp1 &
7472             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
7473         itori=itortyp(itype(i-2,1))
7474         itori1=itortyp(itype(i-1,1))
7475         itori2=itortyp(itype(i,1))
7476         phii=phi(i)
7477         phii1=phi(i+1)
7478         gloci1=0.0D0
7479         gloci2=0.0D0
7480         iblock=1
7481         if (iabs(itype(i+1,1)).eq.20) iblock=2
7482
7483 ! Regular cosine and sine terms
7484         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7485           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7486           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7487           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7488           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7489           cosphi1=dcos(j*phii)
7490           sinphi1=dsin(j*phii)
7491           cosphi2=dcos(j*phii1)
7492           sinphi2=dsin(j*phii1)
7493           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
7494            v2cij*cosphi2+v2sij*sinphi2
7495           if (energy_dec) etors_d_ii=etors_d_ii+ &
7496            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7497           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7498           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7499         enddo
7500         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7501           do l=1,k-1
7502             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7503             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7504             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7505             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7506             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7507             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7508             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7509             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7510             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7511               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7512             if (energy_dec) etors_d_ii=etors_d_ii+ &
7513               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7514               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7515             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
7516               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7517             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
7518               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7519           enddo
7520         enddo
7521         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7522                             'etor_d',i,etors_d_ii
7523         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7524         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7525       enddo
7526       return
7527       end subroutine etor_d
7528 #endif
7529
7530       subroutine ebend_kcc(etheta)
7531       logical lprn
7532       double precision thybt1(maxang_kcc),etheta
7533       integer :: i,iti,j,ihelp
7534       real (kind=8) :: sinthet,costhet,sumth1thyb,gradthybt1
7535 !C Set lprn=.true. for debugging
7536       lprn=energy_dec
7537 !c     lprn=.true.
7538 !C      print *,"wchodze kcc"
7539       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7540       etheta=0.0D0
7541       do i=ithet_start,ithet_end
7542 !c        print *,i,itype(i-1),itype(i),itype(i-2)
7543         if ((itype(i-1,1).eq.ntyp1).or.itype(i-2,1).eq.ntyp1 &
7544        .or.itype(i,1).eq.ntyp1) cycle
7545         iti=iabs(itortyp(itype(i-1,1)))
7546         sinthet=dsin(theta(i))
7547         costhet=dcos(theta(i))
7548         do j=1,nbend_kcc_Tb(iti)
7549           thybt1(j)=v1bend_chyb(j,iti)
7550         enddo
7551         sumth1thyb=v1bend_chyb(0,iti)+ &
7552          tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7553         if (lprn) write (iout,*) i-1,itype(i-1,1),iti,theta(i)*rad2deg,&
7554          sumth1thyb
7555         ihelp=nbend_kcc_Tb(iti)-1
7556         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
7557         etheta=etheta+sumth1thyb
7558 !C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7559         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
7560       enddo
7561       return
7562       end subroutine ebend_kcc
7563 !c------------
7564 !c-------------------------------------------------------------------------------------
7565       subroutine etheta_constr(ethetacnstr)
7566       real (kind=8) :: ethetacnstr,thetiii,difi
7567       integer :: i,itheta
7568       ethetacnstr=0.0d0
7569 !C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7570       do i=ithetaconstr_start,ithetaconstr_end
7571         itheta=itheta_constr(i)
7572         thetiii=theta(itheta)
7573         difi=pinorm(thetiii-theta_constr0(i))
7574         if (difi.gt.theta_drange(i)) then
7575           difi=difi-theta_drange(i)
7576           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7577           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
7578          +for_thet_constr(i)*difi**3
7579         else if (difi.lt.-drange(i)) then
7580           difi=difi+drange(i)
7581           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7582           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
7583           +for_thet_constr(i)*difi**3
7584         else
7585           difi=0.0
7586         endif
7587        if (energy_dec) then
7588         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",&
7589          i,itheta,rad2deg*thetiii,&
7590          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),&
7591          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,&
7592          gloc(itheta+nphi-2,icg)
7593         endif
7594       enddo
7595       return
7596       end subroutine etheta_constr
7597
7598 !-----------------------------------------------------------------------------
7599       subroutine eback_sc_corr(esccor)
7600 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
7601 !        conformational states; temporarily implemented as differences
7602 !        between UNRES torsional potentials (dependent on three types of
7603 !        residues) and the torsional potentials dependent on all 20 types
7604 !        of residues computed from AM1  energy surfaces of terminally-blocked
7605 !        amino-acid residues.
7606 !      implicit real*8 (a-h,o-z)
7607 !      include 'DIMENSIONS'
7608 !      include 'COMMON.VAR'
7609 !      include 'COMMON.GEO'
7610 !      include 'COMMON.LOCAL'
7611 !      include 'COMMON.TORSION'
7612 !      include 'COMMON.SCCOR'
7613 !      include 'COMMON.INTERACT'
7614 !      include 'COMMON.DERIV'
7615 !      include 'COMMON.CHAIN'
7616 !      include 'COMMON.NAMES'
7617 !      include 'COMMON.IOUNITS'
7618 !      include 'COMMON.FFIELD'
7619 !      include 'COMMON.CONTROL'
7620       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
7621                    cosphi,sinphi
7622       logical :: lprn
7623       integer :: i,interty,j,isccori,isccori1,intertyp
7624 ! Set lprn=.true. for debugging
7625       lprn=.false.
7626 !      lprn=.true.
7627 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7628       esccor=0.0D0
7629       do i=itau_start,itau_end
7630         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
7631         esccor_ii=0.0D0
7632         isccori=isccortyp(itype(i-2,1))
7633         isccori1=isccortyp(itype(i-1,1))
7634
7635 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7636         phii=phi(i)
7637         do intertyp=1,3 !intertyp
7638          esccor_ii=0.0D0
7639 !c Added 09 May 2012 (Adasko)
7640 !c  Intertyp means interaction type of backbone mainchain correlation:
7641 !   1 = SC...Ca...Ca...Ca
7642 !   2 = Ca...Ca...Ca...SC
7643 !   3 = SC...Ca...Ca...SCi
7644         gloci=0.0D0
7645         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
7646             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
7647             (itype(i-1,1).eq.ntyp1))) &
7648           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
7649            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
7650            .or.(itype(i,1).eq.ntyp1))) &
7651           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
7652             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
7653             (itype(i-3,1).eq.ntyp1)))) cycle
7654         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
7655         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
7656        cycle
7657        do j=1,nterm_sccor(isccori,isccori1)
7658           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7659           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7660           cosphi=dcos(j*tauangle(intertyp,i))
7661           sinphi=dsin(j*tauangle(intertyp,i))
7662           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7663           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7664           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7665         enddo
7666         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
7667                                 'esccor',i,intertyp,esccor_ii
7668 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7669         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7670         if (lprn) &
7671         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7672         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
7673         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
7674         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7675         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7676        enddo !intertyp
7677       enddo
7678
7679       return
7680       end subroutine eback_sc_corr
7681 !-----------------------------------------------------------------------------
7682       subroutine multibody(ecorr)
7683 ! This subroutine calculates multi-body contributions to energy following
7684 ! the idea of Skolnick et al. If side chains I and J make a contact and
7685 ! at the same time side chains I+1 and J+1 make a contact, an extra
7686 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7687 !      implicit real*8 (a-h,o-z)
7688 !      include 'DIMENSIONS'
7689 !      include 'COMMON.IOUNITS'
7690 !      include 'COMMON.DERIV'
7691 !      include 'COMMON.INTERACT'
7692 !      include 'COMMON.CONTACTS'
7693       real(kind=8),dimension(3) :: gx,gx1
7694       logical :: lprn
7695       real(kind=8) :: ecorr
7696       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
7697 ! Set lprn=.true. for debugging
7698       lprn=.false.
7699
7700       if (lprn) then
7701         write (iout,'(a)') 'Contact function values:'
7702         do i=nnt,nct-2
7703           write (iout,'(i2,20(1x,i2,f10.5))') &
7704               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7705         enddo
7706       endif
7707       ecorr=0.0D0
7708
7709 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7710 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7711       do i=nnt,nct
7712         do j=1,3
7713           gradcorr(j,i)=0.0D0
7714           gradxorr(j,i)=0.0D0
7715         enddo
7716       enddo
7717       do i=nnt,nct-2
7718
7719         DO ISHIFT = 3,4
7720
7721         i1=i+ishift
7722         num_conti=num_cont(i)
7723         num_conti1=num_cont(i1)
7724         do jj=1,num_conti
7725           j=jcont(jj,i)
7726           do kk=1,num_conti1
7727             j1=jcont(kk,i1)
7728             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7729 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7730 !d   &                   ' ishift=',ishift
7731 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7732 ! The system gains extra energy.
7733               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7734             endif   ! j1==j+-ishift
7735           enddo     ! kk
7736         enddo       ! jj
7737
7738         ENDDO ! ISHIFT
7739
7740       enddo         ! i
7741       return
7742       end subroutine multibody
7743 !-----------------------------------------------------------------------------
7744       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7745 !      implicit real*8 (a-h,o-z)
7746 !      include 'DIMENSIONS'
7747 !      include 'COMMON.IOUNITS'
7748 !      include 'COMMON.DERIV'
7749 !      include 'COMMON.INTERACT'
7750 !      include 'COMMON.CONTACTS'
7751       real(kind=8),dimension(3) :: gx,gx1
7752       logical :: lprn
7753       integer :: i,j,k,l,jj,kk,m,ll
7754       real(kind=8) :: eij,ekl
7755       lprn=.false.
7756       eij=facont(jj,i)
7757       ekl=facont(kk,k)
7758 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7759 ! Calculate the multi-body contribution to energy.
7760 ! Calculate multi-body contributions to the gradient.
7761 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7762 !d   & k,l,(gacont(m,kk,k),m=1,3)
7763       do m=1,3
7764         gx(m) =ekl*gacont(m,jj,i)
7765         gx1(m)=eij*gacont(m,kk,k)
7766         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7767         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7768         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7769         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7770       enddo
7771       do m=i,j-1
7772         do ll=1,3
7773           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7774         enddo
7775       enddo
7776       do m=k,l-1
7777         do ll=1,3
7778           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7779         enddo
7780       enddo
7781       esccorr=-eij*ekl
7782       return
7783       end function esccorr
7784 !-----------------------------------------------------------------------------
7785       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7786 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7787 !      implicit real*8 (a-h,o-z)
7788 !      include 'DIMENSIONS'
7789 !      include 'COMMON.IOUNITS'
7790 #ifdef MPI
7791       include "mpif.h"
7792 !      integer :: maxconts !max_cont=maxconts  =nres/4
7793       integer,parameter :: max_dim=26
7794       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7795       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7796 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7797 !el      common /przechowalnia/ zapas
7798       integer :: status(MPI_STATUS_SIZE)
7799       integer,dimension((nres/4)*2) :: req !maxconts*2
7800       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7801 #endif
7802 !      include 'COMMON.SETUP'
7803 !      include 'COMMON.FFIELD'
7804 !      include 'COMMON.DERIV'
7805 !      include 'COMMON.INTERACT'
7806 !      include 'COMMON.CONTACTS'
7807 !      include 'COMMON.CONTROL'
7808 !      include 'COMMON.LOCAL'
7809       real(kind=8),dimension(3) :: gx,gx1
7810       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7811       logical :: lprn,ldone
7812 !el local variables
7813       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7814               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7815
7816 ! Set lprn=.true. for debugging
7817       lprn=.false.
7818 #ifdef MPI
7819 !      maxconts=nres/4
7820       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7821       n_corr=0
7822       n_corr1=0
7823       if (nfgtasks.le.1) goto 30
7824       if (lprn) then
7825         write (iout,'(a)') 'Contact function values before RECEIVE:'
7826         do i=nnt,nct-2
7827           write (iout,'(2i3,50(1x,i2,f5.2))') &
7828           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7829           j=1,num_cont_hb(i))
7830         enddo
7831       endif
7832       call flush(iout)
7833       do i=1,ntask_cont_from
7834         ncont_recv(i)=0
7835       enddo
7836       do i=1,ntask_cont_to
7837         ncont_sent(i)=0
7838       enddo
7839 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7840 !     & ntask_cont_to
7841 ! Make the list of contacts to send to send to other procesors
7842 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7843 !      call flush(iout)
7844       do i=iturn3_start,iturn3_end
7845 !        write (iout,*) "make contact list turn3",i," num_cont",
7846 !     &    num_cont_hb(i)
7847         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7848       enddo
7849       do i=iturn4_start,iturn4_end
7850 !        write (iout,*) "make contact list turn4",i," num_cont",
7851 !     &   num_cont_hb(i)
7852         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7853       enddo
7854       do ii=1,nat_sent
7855         i=iat_sent(ii)
7856 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7857 !     &    num_cont_hb(i)
7858         do j=1,num_cont_hb(i)
7859         do k=1,4
7860           jjc=jcont_hb(j,i)
7861           iproc=iint_sent_local(k,jjc,ii)
7862 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7863           if (iproc.gt.0) then
7864             ncont_sent(iproc)=ncont_sent(iproc)+1
7865             nn=ncont_sent(iproc)
7866             zapas(1,nn,iproc)=i
7867             zapas(2,nn,iproc)=jjc
7868             zapas(3,nn,iproc)=facont_hb(j,i)
7869             zapas(4,nn,iproc)=ees0p(j,i)
7870             zapas(5,nn,iproc)=ees0m(j,i)
7871             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7872             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7873             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7874             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7875             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7876             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7877             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7878             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7879             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7880             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7881             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7882             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7883             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7884             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7885             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7886             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7887             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7888             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7889             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7890             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7891             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7892           endif
7893         enddo
7894         enddo
7895       enddo
7896       if (lprn) then
7897       write (iout,*) &
7898         "Numbers of contacts to be sent to other processors",&
7899         (ncont_sent(i),i=1,ntask_cont_to)
7900       write (iout,*) "Contacts sent"
7901       do ii=1,ntask_cont_to
7902         nn=ncont_sent(ii)
7903         iproc=itask_cont_to(ii)
7904         write (iout,*) nn," contacts to processor",iproc,&
7905          " of CONT_TO_COMM group"
7906         do i=1,nn
7907           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7908         enddo
7909       enddo
7910       call flush(iout)
7911       endif
7912       CorrelType=477
7913       CorrelID=fg_rank+1
7914       CorrelType1=478
7915       CorrelID1=nfgtasks+fg_rank+1
7916       ireq=0
7917 ! Receive the numbers of needed contacts from other processors
7918       do ii=1,ntask_cont_from
7919         iproc=itask_cont_from(ii)
7920         ireq=ireq+1
7921         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7922           FG_COMM,req(ireq),IERR)
7923       enddo
7924 !      write (iout,*) "IRECV ended"
7925 !      call flush(iout)
7926 ! Send the number of contacts needed by other processors
7927       do ii=1,ntask_cont_to
7928         iproc=itask_cont_to(ii)
7929         ireq=ireq+1
7930         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7931           FG_COMM,req(ireq),IERR)
7932       enddo
7933 !      write (iout,*) "ISEND ended"
7934 !      write (iout,*) "number of requests (nn)",ireq
7935       call flush(iout)
7936       if (ireq.gt.0) &
7937         call MPI_Waitall(ireq,req,status_array,ierr)
7938 !      write (iout,*)
7939 !     &  "Numbers of contacts to be received from other processors",
7940 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7941 !      call flush(iout)
7942 ! Receive contacts
7943       ireq=0
7944       do ii=1,ntask_cont_from
7945         iproc=itask_cont_from(ii)
7946         nn=ncont_recv(ii)
7947 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7948 !     &   " of CONT_TO_COMM group"
7949         call flush(iout)
7950         if (nn.gt.0) then
7951           ireq=ireq+1
7952           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7953           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7954 !          write (iout,*) "ireq,req",ireq,req(ireq)
7955         endif
7956       enddo
7957 ! Send the contacts to processors that need them
7958       do ii=1,ntask_cont_to
7959         iproc=itask_cont_to(ii)
7960         nn=ncont_sent(ii)
7961 !        write (iout,*) nn," contacts to processor",iproc,
7962 !     &   " of CONT_TO_COMM group"
7963         if (nn.gt.0) then
7964           ireq=ireq+1
7965           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7966             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7967 !          write (iout,*) "ireq,req",ireq,req(ireq)
7968 !          do i=1,nn
7969 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7970 !          enddo
7971         endif
7972       enddo
7973 !      write (iout,*) "number of requests (contacts)",ireq
7974 !      write (iout,*) "req",(req(i),i=1,4)
7975 !      call flush(iout)
7976       if (ireq.gt.0) &
7977        call MPI_Waitall(ireq,req,status_array,ierr)
7978       do iii=1,ntask_cont_from
7979         iproc=itask_cont_from(iii)
7980         nn=ncont_recv(iii)
7981         if (lprn) then
7982         write (iout,*) "Received",nn," contacts from processor",iproc,&
7983          " of CONT_FROM_COMM group"
7984         call flush(iout)
7985         do i=1,nn
7986           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7987         enddo
7988         call flush(iout)
7989         endif
7990         do i=1,nn
7991           ii=zapas_recv(1,i,iii)
7992 ! Flag the received contacts to prevent double-counting
7993           jj=-zapas_recv(2,i,iii)
7994 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7995 !          call flush(iout)
7996           nnn=num_cont_hb(ii)+1
7997           num_cont_hb(ii)=nnn
7998           jcont_hb(nnn,ii)=jj
7999           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8000           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8001           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8002           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8003           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8004           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8005           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8006           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8007           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8008           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8009           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8010           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8011           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8012           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8013           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8014           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8015           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8016           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8017           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8018           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8019           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8020           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8021           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8022           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8023         enddo
8024       enddo
8025       call flush(iout)
8026       if (lprn) then
8027         write (iout,'(a)') 'Contact function values after receive:'
8028         do i=nnt,nct-2
8029           write (iout,'(2i3,50(1x,i3,f5.2))') &
8030           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8031           j=1,num_cont_hb(i))
8032         enddo
8033         call flush(iout)
8034       endif
8035    30 continue
8036 #endif
8037       if (lprn) then
8038         write (iout,'(a)') 'Contact function values:'
8039         do i=nnt,nct-2
8040           write (iout,'(2i3,50(1x,i3,f5.2))') &
8041           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8042           j=1,num_cont_hb(i))
8043         enddo
8044       endif
8045       ecorr=0.0D0
8046
8047 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8048 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8049 ! Remove the loop below after debugging !!!
8050       do i=nnt,nct
8051         do j=1,3
8052           gradcorr(j,i)=0.0D0
8053           gradxorr(j,i)=0.0D0
8054         enddo
8055       enddo
8056 ! Calculate the local-electrostatic correlation terms
8057       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8058         i1=i+1
8059         num_conti=num_cont_hb(i)
8060         num_conti1=num_cont_hb(i+1)
8061         do jj=1,num_conti
8062           j=jcont_hb(jj,i)
8063           jp=iabs(j)
8064           do kk=1,num_conti1
8065             j1=jcont_hb(kk,i1)
8066             jp1=iabs(j1)
8067 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
8068 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
8069             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8070                 .or. j.lt.0 .and. j1.gt.0) .and. &
8071                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8072 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8073 ! The system gains extra energy.
8074               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8075               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
8076                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8077               n_corr=n_corr+1
8078             else if (j1.eq.j) then
8079 ! Contacts I-J and I-(J+1) occur simultaneously.
8080 ! The system loses extra energy.
8081 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8082             endif
8083           enddo ! kk
8084           do kk=1,num_conti
8085             j1=jcont_hb(kk,i)
8086 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8087 !    &         ' jj=',jj,' kk=',kk
8088             if (j1.eq.j+1) then
8089 ! Contacts I-J and (I+1)-J occur simultaneously.
8090 ! The system loses extra energy.
8091 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8092             endif ! j1==j+1
8093           enddo ! kk
8094         enddo ! jj
8095       enddo ! i
8096       return
8097       end subroutine multibody_hb
8098 !-----------------------------------------------------------------------------
8099       subroutine add_hb_contact(ii,jj,itask)
8100 !      implicit real*8 (a-h,o-z)
8101 !      include "DIMENSIONS"
8102 !      include "COMMON.IOUNITS"
8103 !      include "COMMON.CONTACTS"
8104 !      integer,parameter :: maxconts=nres/4
8105       integer,parameter :: max_dim=26
8106       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8107 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
8108 !      common /przechowalnia/ zapas
8109       integer :: i,j,ii,jj,iproc,nn,jjc
8110       integer,dimension(4) :: itask
8111 !      write (iout,*) "itask",itask
8112       do i=1,2
8113         iproc=itask(i)
8114         if (iproc.gt.0) then
8115           do j=1,num_cont_hb(ii)
8116             jjc=jcont_hb(j,ii)
8117 !            write (iout,*) "i",ii," j",jj," jjc",jjc
8118             if (jjc.eq.jj) then
8119               ncont_sent(iproc)=ncont_sent(iproc)+1
8120               nn=ncont_sent(iproc)
8121               zapas(1,nn,iproc)=ii
8122               zapas(2,nn,iproc)=jjc
8123               zapas(3,nn,iproc)=facont_hb(j,ii)
8124               zapas(4,nn,iproc)=ees0p(j,ii)
8125               zapas(5,nn,iproc)=ees0m(j,ii)
8126               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8127               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8128               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8129               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8130               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8131               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8132               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8133               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8134               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8135               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8136               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8137               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8138               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8139               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8140               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8141               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8142               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8143               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8144               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8145               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8146               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8147               exit
8148             endif
8149           enddo
8150         endif
8151       enddo
8152       return
8153       end subroutine add_hb_contact
8154 !-----------------------------------------------------------------------------
8155       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
8156 ! This subroutine calculates multi-body contributions to hydrogen-bonding
8157 !      implicit real*8 (a-h,o-z)
8158 !      include 'DIMENSIONS'
8159 !      include 'COMMON.IOUNITS'
8160       integer,parameter :: max_dim=70
8161 #ifdef MPI
8162       include "mpif.h"
8163 !      integer :: maxconts !max_cont=maxconts=nres/4
8164       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8165       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8166 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8167 !      common /przechowalnia/ zapas
8168       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
8169         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
8170         ierr,iii,nnn
8171 #endif
8172 !      include 'COMMON.SETUP'
8173 !      include 'COMMON.FFIELD'
8174 !      include 'COMMON.DERIV'
8175 !      include 'COMMON.LOCAL'
8176 !      include 'COMMON.INTERACT'
8177 !      include 'COMMON.CONTACTS'
8178 !      include 'COMMON.CHAIN'
8179 !      include 'COMMON.CONTROL'
8180       real(kind=8),dimension(3) :: gx,gx1
8181       integer,dimension(nres) :: num_cont_hb_old
8182       logical :: lprn,ldone
8183 !EL      double precision eello4,eello5,eelo6,eello_turn6
8184 !EL      external eello4,eello5,eello6,eello_turn6
8185 !el local variables
8186       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
8187               j1,jp1,i1,num_conti1
8188       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
8189       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
8190
8191 ! Set lprn=.true. for debugging
8192       lprn=.false.
8193       eturn6=0.0d0
8194 #ifdef MPI
8195 !      maxconts=nres/4
8196       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
8197       do i=1,nres
8198         num_cont_hb_old(i)=num_cont_hb(i)
8199       enddo
8200       n_corr=0
8201       n_corr1=0
8202       if (nfgtasks.le.1) goto 30
8203       if (lprn) then
8204         write (iout,'(a)') 'Contact function values before RECEIVE:'
8205         do i=nnt,nct-2
8206           write (iout,'(2i3,50(1x,i2,f5.2))') &
8207           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8208           j=1,num_cont_hb(i))
8209         enddo
8210       endif
8211       call flush(iout)
8212       do i=1,ntask_cont_from
8213         ncont_recv(i)=0
8214       enddo
8215       do i=1,ntask_cont_to
8216         ncont_sent(i)=0
8217       enddo
8218 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8219 !     & ntask_cont_to
8220 ! Make the list of contacts to send to send to other procesors
8221       do i=iturn3_start,iturn3_end
8222 !        write (iout,*) "make contact list turn3",i," num_cont",
8223 !     &    num_cont_hb(i)
8224         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8225       enddo
8226       do i=iturn4_start,iturn4_end
8227 !        write (iout,*) "make contact list turn4",i," num_cont",
8228 !     &   num_cont_hb(i)
8229         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8230       enddo
8231       do ii=1,nat_sent
8232         i=iat_sent(ii)
8233 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8234 !     &    num_cont_hb(i)
8235         do j=1,num_cont_hb(i)
8236         do k=1,4
8237           jjc=jcont_hb(j,i)
8238           iproc=iint_sent_local(k,jjc,ii)
8239 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8240           if (iproc.ne.0) then
8241             ncont_sent(iproc)=ncont_sent(iproc)+1
8242             nn=ncont_sent(iproc)
8243             zapas(1,nn,iproc)=i
8244             zapas(2,nn,iproc)=jjc
8245             zapas(3,nn,iproc)=d_cont(j,i)
8246             ind=3
8247             do kk=1,3
8248               ind=ind+1
8249               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8250             enddo
8251             do kk=1,2
8252               do ll=1,2
8253                 ind=ind+1
8254                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8255               enddo
8256             enddo
8257             do jj=1,5
8258               do kk=1,3
8259                 do ll=1,2
8260                   do mm=1,2
8261                     ind=ind+1
8262                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8263                   enddo
8264                 enddo
8265               enddo
8266             enddo
8267           endif
8268         enddo
8269         enddo
8270       enddo
8271       if (lprn) then
8272       write (iout,*) &
8273         "Numbers of contacts to be sent to other processors",&
8274         (ncont_sent(i),i=1,ntask_cont_to)
8275       write (iout,*) "Contacts sent"
8276       do ii=1,ntask_cont_to
8277         nn=ncont_sent(ii)
8278         iproc=itask_cont_to(ii)
8279         write (iout,*) nn," contacts to processor",iproc,&
8280          " of CONT_TO_COMM group"
8281         do i=1,nn
8282           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8283         enddo
8284       enddo
8285       call flush(iout)
8286       endif
8287       CorrelType=477
8288       CorrelID=fg_rank+1
8289       CorrelType1=478
8290       CorrelID1=nfgtasks+fg_rank+1
8291       ireq=0
8292 ! Receive the numbers of needed contacts from other processors
8293       do ii=1,ntask_cont_from
8294         iproc=itask_cont_from(ii)
8295         ireq=ireq+1
8296         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8297           FG_COMM,req(ireq),IERR)
8298       enddo
8299 !      write (iout,*) "IRECV ended"
8300 !      call flush(iout)
8301 ! Send the number of contacts needed by other processors
8302       do ii=1,ntask_cont_to
8303         iproc=itask_cont_to(ii)
8304         ireq=ireq+1
8305         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8306           FG_COMM,req(ireq),IERR)
8307       enddo
8308 !      write (iout,*) "ISEND ended"
8309 !      write (iout,*) "number of requests (nn)",ireq
8310       call flush(iout)
8311       if (ireq.gt.0) &
8312         call MPI_Waitall(ireq,req,status_array,ierr)
8313 !      write (iout,*)
8314 !     &  "Numbers of contacts to be received from other processors",
8315 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8316 !      call flush(iout)
8317 ! Receive contacts
8318       ireq=0
8319       do ii=1,ntask_cont_from
8320         iproc=itask_cont_from(ii)
8321         nn=ncont_recv(ii)
8322 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8323 !     &   " of CONT_TO_COMM group"
8324         call flush(iout)
8325         if (nn.gt.0) then
8326           ireq=ireq+1
8327           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
8328           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8329 !          write (iout,*) "ireq,req",ireq,req(ireq)
8330         endif
8331       enddo
8332 ! Send the contacts to processors that need them
8333       do ii=1,ntask_cont_to
8334         iproc=itask_cont_to(ii)
8335         nn=ncont_sent(ii)
8336 !        write (iout,*) nn," contacts to processor",iproc,
8337 !     &   " of CONT_TO_COMM group"
8338         if (nn.gt.0) then
8339           ireq=ireq+1
8340           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8341             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8342 !          write (iout,*) "ireq,req",ireq,req(ireq)
8343 !          do i=1,nn
8344 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8345 !          enddo
8346         endif
8347       enddo
8348 !      write (iout,*) "number of requests (contacts)",ireq
8349 !      write (iout,*) "req",(req(i),i=1,4)
8350 !      call flush(iout)
8351       if (ireq.gt.0) &
8352        call MPI_Waitall(ireq,req,status_array,ierr)
8353       do iii=1,ntask_cont_from
8354         iproc=itask_cont_from(iii)
8355         nn=ncont_recv(iii)
8356         if (lprn) then
8357         write (iout,*) "Received",nn," contacts from processor",iproc,&
8358          " of CONT_FROM_COMM group"
8359         call flush(iout)
8360         do i=1,nn
8361           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8362         enddo
8363         call flush(iout)
8364         endif
8365         do i=1,nn
8366           ii=zapas_recv(1,i,iii)
8367 ! Flag the received contacts to prevent double-counting
8368           jj=-zapas_recv(2,i,iii)
8369 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8370 !          call flush(iout)
8371           nnn=num_cont_hb(ii)+1
8372           num_cont_hb(ii)=nnn
8373           jcont_hb(nnn,ii)=jj
8374           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8375           ind=3
8376           do kk=1,3
8377             ind=ind+1
8378             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8379           enddo
8380           do kk=1,2
8381             do ll=1,2
8382               ind=ind+1
8383               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8384             enddo
8385           enddo
8386           do jj=1,5
8387             do kk=1,3
8388               do ll=1,2
8389                 do mm=1,2
8390                   ind=ind+1
8391                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8392                 enddo
8393               enddo
8394             enddo
8395           enddo
8396         enddo
8397       enddo
8398       call flush(iout)
8399       if (lprn) then
8400         write (iout,'(a)') 'Contact function values after receive:'
8401         do i=nnt,nct-2
8402           write (iout,'(2i3,50(1x,i3,5f6.3))') &
8403           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8404           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8405         enddo
8406         call flush(iout)
8407       endif
8408    30 continue
8409 #endif
8410       if (lprn) then
8411         write (iout,'(a)') 'Contact function values:'
8412         do i=nnt,nct-2
8413           write (iout,'(2i3,50(1x,i2,5f6.3))') &
8414           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8415           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8416         enddo
8417       endif
8418       ecorr=0.0D0
8419       ecorr5=0.0d0
8420       ecorr6=0.0d0
8421
8422 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8423 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8424 ! Remove the loop below after debugging !!!
8425       do i=nnt,nct
8426         do j=1,3
8427           gradcorr(j,i)=0.0D0
8428           gradxorr(j,i)=0.0D0
8429         enddo
8430       enddo
8431 ! Calculate the dipole-dipole interaction energies
8432       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8433       do i=iatel_s,iatel_e+1
8434         num_conti=num_cont_hb(i)
8435         do jj=1,num_conti
8436           j=jcont_hb(jj,i)
8437 #ifdef MOMENT
8438           call dipole(i,j,jj)
8439 #endif
8440         enddo
8441       enddo
8442       endif
8443 ! Calculate the local-electrostatic correlation terms
8444 !                write (iout,*) "gradcorr5 in eello5 before loop"
8445 !                do iii=1,nres
8446 !                  write (iout,'(i5,3f10.5)')
8447 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8448 !                enddo
8449       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8450 !        write (iout,*) "corr loop i",i
8451         i1=i+1
8452         num_conti=num_cont_hb(i)
8453         num_conti1=num_cont_hb(i+1)
8454         do jj=1,num_conti
8455           j=jcont_hb(jj,i)
8456           jp=iabs(j)
8457           do kk=1,num_conti1
8458             j1=jcont_hb(kk,i1)
8459             jp1=iabs(j1)
8460 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8461 !     &         ' jj=',jj,' kk=',kk
8462 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
8463             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8464                 .or. j.lt.0 .and. j1.gt.0) .and. &
8465                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8466 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8467 ! The system gains extra energy.
8468               n_corr=n_corr+1
8469               sqd1=dsqrt(d_cont(jj,i))
8470               sqd2=dsqrt(d_cont(kk,i1))
8471               sred_geom = sqd1*sqd2
8472               IF (sred_geom.lt.cutoff_corr) THEN
8473                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
8474                   ekont,fprimcont)
8475 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8476 !d     &         ' jj=',jj,' kk=',kk
8477                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8478                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8479                 do l=1,3
8480                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8481                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8482                 enddo
8483                 n_corr1=n_corr1+1
8484 !d               write (iout,*) 'sred_geom=',sred_geom,
8485 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
8486 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8487 !d               write (iout,*) "g_contij",g_contij
8488 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8489 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8490                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8491                 if (wcorr4.gt.0.0d0) &
8492                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8493                   if (energy_dec.and.wcorr4.gt.0.0d0) &
8494                        write (iout,'(a6,4i5,0pf7.3)') &
8495                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8496 !                write (iout,*) "gradcorr5 before eello5"
8497 !                do iii=1,nres
8498 !                  write (iout,'(i5,3f10.5)')
8499 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8500 !                enddo
8501                 if (wcorr5.gt.0.0d0) &
8502                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8503 !                write (iout,*) "gradcorr5 after eello5"
8504 !                do iii=1,nres
8505 !                  write (iout,'(i5,3f10.5)')
8506 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8507 !                enddo
8508                   if (energy_dec.and.wcorr5.gt.0.0d0) &
8509                        write (iout,'(a6,4i5,0pf7.3)') &
8510                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8511 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8512 !d                write(2,*)'ijkl',i,jp,i+1,jp1
8513                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
8514                      .or. wturn6.eq.0.0d0))then
8515 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8516                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8517                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8518                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8519 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8520 !d     &            'ecorr6=',ecorr6
8521 !d                write (iout,'(4e15.5)') sred_geom,
8522 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8523 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8524 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8525                 else if (wturn6.gt.0.0d0 &
8526                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8527 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8528                   eturn6=eturn6+eello_turn6(i,jj,kk)
8529                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8530                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8531 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
8532                 endif
8533               ENDIF
8534 1111          continue
8535             endif
8536           enddo ! kk
8537         enddo ! jj
8538       enddo ! i
8539       do i=1,nres
8540         num_cont_hb(i)=num_cont_hb_old(i)
8541       enddo
8542 !                write (iout,*) "gradcorr5 in eello5"
8543 !                do iii=1,nres
8544 !                  write (iout,'(i5,3f10.5)')
8545 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8546 !                enddo
8547       return
8548       end subroutine multibody_eello
8549 !-----------------------------------------------------------------------------
8550       subroutine add_hb_contact_eello(ii,jj,itask)
8551 !      implicit real*8 (a-h,o-z)
8552 !      include "DIMENSIONS"
8553 !      include "COMMON.IOUNITS"
8554 !      include "COMMON.CONTACTS"
8555 !      integer,parameter :: maxconts=nres/4
8556       integer,parameter :: max_dim=70
8557       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8558 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8559 !      common /przechowalnia/ zapas
8560
8561       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
8562       integer,dimension(4) ::itask
8563 !      write (iout,*) "itask",itask
8564       do i=1,2
8565         iproc=itask(i)
8566         if (iproc.gt.0) then
8567           do j=1,num_cont_hb(ii)
8568             jjc=jcont_hb(j,ii)
8569 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8570             if (jjc.eq.jj) then
8571               ncont_sent(iproc)=ncont_sent(iproc)+1
8572               nn=ncont_sent(iproc)
8573               zapas(1,nn,iproc)=ii
8574               zapas(2,nn,iproc)=jjc
8575               zapas(3,nn,iproc)=d_cont(j,ii)
8576               ind=3
8577               do kk=1,3
8578                 ind=ind+1
8579                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8580               enddo
8581               do kk=1,2
8582                 do ll=1,2
8583                   ind=ind+1
8584                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8585                 enddo
8586               enddo
8587               do jj=1,5
8588                 do kk=1,3
8589                   do ll=1,2
8590                     do mm=1,2
8591                       ind=ind+1
8592                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8593                     enddo
8594                   enddo
8595                 enddo
8596               enddo
8597               exit
8598             endif
8599           enddo
8600         endif
8601       enddo
8602       return
8603       end subroutine add_hb_contact_eello
8604 !-----------------------------------------------------------------------------
8605       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8606 !      implicit real*8 (a-h,o-z)
8607 !      include 'DIMENSIONS'
8608 !      include 'COMMON.IOUNITS'
8609 !      include 'COMMON.DERIV'
8610 !      include 'COMMON.INTERACT'
8611 !      include 'COMMON.CONTACTS'
8612       real(kind=8),dimension(3) :: gx,gx1
8613       logical :: lprn
8614 !el local variables
8615       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
8616       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
8617                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
8618                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
8619                    rlocshield
8620
8621       lprn=.false.
8622       eij=facont_hb(jj,i)
8623       ekl=facont_hb(kk,k)
8624       ees0pij=ees0p(jj,i)
8625       ees0pkl=ees0p(kk,k)
8626       ees0mij=ees0m(jj,i)
8627       ees0mkl=ees0m(kk,k)
8628       ekont=eij*ekl
8629       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8630 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8631 ! Following 4 lines for diagnostics.
8632 !d    ees0pkl=0.0D0
8633 !d    ees0pij=1.0D0
8634 !d    ees0mkl=0.0D0
8635 !d    ees0mij=1.0D0
8636 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8637 !     & 'Contacts ',i,j,
8638 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8639 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8640 !     & 'gradcorr_long'
8641 ! Calculate the multi-body contribution to energy.
8642 !      ecorr=ecorr+ekont*ees
8643 ! Calculate multi-body contributions to the gradient.
8644       coeffpees0pij=coeffp*ees0pij
8645       coeffmees0mij=coeffm*ees0mij
8646       coeffpees0pkl=coeffp*ees0pkl
8647       coeffmees0mkl=coeffm*ees0mkl
8648       do ll=1,3
8649 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8650         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
8651         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
8652         coeffmees0mkl*gacontm_hb1(ll,jj,i))
8653         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
8654         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
8655         coeffmees0mkl*gacontm_hb2(ll,jj,i))
8656 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8657         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
8658         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
8659         coeffmees0mij*gacontm_hb1(ll,kk,k))
8660         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
8661         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
8662         coeffmees0mij*gacontm_hb2(ll,kk,k))
8663         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
8664            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
8665            coeffmees0mkl*gacontm_hb3(ll,jj,i))
8666         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8667         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8668         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
8669            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
8670            coeffmees0mij*gacontm_hb3(ll,kk,k))
8671         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8672         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8673 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8674       enddo
8675 !      write (iout,*)
8676 !grad      do m=i+1,j-1
8677 !grad        do ll=1,3
8678 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8679 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8680 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8681 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8682 !grad        enddo
8683 !grad      enddo
8684 !grad      do m=k+1,l-1
8685 !grad        do ll=1,3
8686 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8687 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
8688 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8689 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8690 !grad        enddo
8691 !grad      enddo
8692 !      write (iout,*) "ehbcorr",ekont*ees
8693       ehbcorr=ekont*ees
8694       if (shield_mode.gt.0) then
8695        j=ees0plist(jj,i)
8696        l=ees0plist(kk,k)
8697 !C        print *,i,j,fac_shield(i),fac_shield(j),
8698 !C     &fac_shield(k),fac_shield(l)
8699         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
8700            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8701           do ilist=1,ishield_list(i)
8702            iresshield=shield_list(ilist,i)
8703            do m=1,3
8704            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8705            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8706                    rlocshield  &
8707             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8708             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8709             +rlocshield
8710            enddo
8711           enddo
8712           do ilist=1,ishield_list(j)
8713            iresshield=shield_list(ilist,j)
8714            do m=1,3
8715            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8716            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8717                    rlocshield &
8718             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8719            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8720             +rlocshield
8721            enddo
8722           enddo
8723
8724           do ilist=1,ishield_list(k)
8725            iresshield=shield_list(ilist,k)
8726            do m=1,3
8727            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8728            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8729                    rlocshield &
8730             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8731            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8732             +rlocshield
8733            enddo
8734           enddo
8735           do ilist=1,ishield_list(l)
8736            iresshield=shield_list(ilist,l)
8737            do m=1,3
8738            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8739            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8740                    rlocshield &
8741             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8742            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8743             +rlocshield
8744            enddo
8745           enddo
8746           do m=1,3
8747             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8748                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8749             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8750                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8751             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8752                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8753             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8754                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8755
8756             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8757                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8758             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8759                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8760             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8761                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8762             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8763                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8764
8765            enddo
8766       endif
8767       endif
8768       return
8769       end function ehbcorr
8770 #ifdef MOMENT
8771 !-----------------------------------------------------------------------------
8772       subroutine dipole(i,j,jj)
8773 !      implicit real*8 (a-h,o-z)
8774 !      include 'DIMENSIONS'
8775 !      include 'COMMON.IOUNITS'
8776 !      include 'COMMON.CHAIN'
8777 !      include 'COMMON.FFIELD'
8778 !      include 'COMMON.DERIV'
8779 !      include 'COMMON.INTERACT'
8780 !      include 'COMMON.CONTACTS'
8781 !      include 'COMMON.TORSION'
8782 !      include 'COMMON.VAR'
8783 !      include 'COMMON.GEO'
8784       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8785       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8786       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8787
8788       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8789       allocate(dipderx(3,5,4,maxconts,nres))
8790 !
8791
8792       iti1 = itortyp(itype(i+1,1))
8793       if (j.lt.nres-1) then
8794         itj1 = itype2loc(itype(j+1,1))
8795       else
8796         itj1=nloctyp
8797       endif
8798       do iii=1,2
8799         dipi(iii,1)=Ub2(iii,i)
8800         dipderi(iii)=Ub2der(iii,i)
8801         dipi(iii,2)=b1(iii,iti1)
8802         dipj(iii,1)=Ub2(iii,j)
8803         dipderj(iii)=Ub2der(iii,j)
8804         dipj(iii,2)=b1(iii,itj1)
8805       enddo
8806       kkk=0
8807       do iii=1,2
8808         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8809         do jjj=1,2
8810           kkk=kkk+1
8811           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8812         enddo
8813       enddo
8814       do kkk=1,5
8815         do lll=1,3
8816           mmm=0
8817           do iii=1,2
8818             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8819               auxvec(1))
8820             do jjj=1,2
8821               mmm=mmm+1
8822               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8823             enddo
8824           enddo
8825         enddo
8826       enddo
8827       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8828       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8829       do iii=1,2
8830         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8831       enddo
8832       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8833       do iii=1,2
8834         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8835       enddo
8836       return
8837       end subroutine dipole
8838 #endif
8839 !-----------------------------------------------------------------------------
8840       subroutine calc_eello(i,j,k,l,jj,kk)
8841 !
8842 ! This subroutine computes matrices and vectors needed to calculate
8843 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
8844 !
8845       use comm_kut
8846 !      implicit real*8 (a-h,o-z)
8847 !      include 'DIMENSIONS'
8848 !      include 'COMMON.IOUNITS'
8849 !      include 'COMMON.CHAIN'
8850 !      include 'COMMON.DERIV'
8851 !      include 'COMMON.INTERACT'
8852 !      include 'COMMON.CONTACTS'
8853 !      include 'COMMON.TORSION'
8854 !      include 'COMMON.VAR'
8855 !      include 'COMMON.GEO'
8856 !      include 'COMMON.FFIELD'
8857       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
8858       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
8859       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
8860               itj1
8861 !el      logical :: lprn
8862 !el      common /kutas/ lprn
8863 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8864 !d     & ' jj=',jj,' kk=',kk
8865 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8866 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8867 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8868       do iii=1,2
8869         do jjj=1,2
8870           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8871           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8872         enddo
8873       enddo
8874       call transpose2(aa1(1,1),aa1t(1,1))
8875       call transpose2(aa2(1,1),aa2t(1,1))
8876       do kkk=1,5
8877         do lll=1,3
8878           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
8879             aa1tder(1,1,lll,kkk))
8880           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
8881             aa2tder(1,1,lll,kkk))
8882         enddo
8883       enddo
8884       if (l.eq.j+1) then
8885 ! parallel orientation of the two CA-CA-CA frames.
8886         if (i.gt.1) then
8887           iti=itortyp(itype(i,1))
8888         else
8889           iti=ntortyp+1
8890         endif
8891         itk1=itortyp(itype(k+1,1))
8892         itj=itortyp(itype(j,1))
8893         if (l.lt.nres-1) then
8894           itl1=itortyp(itype(l+1,1))
8895         else
8896           itl1=ntortyp+1
8897         endif
8898 ! A1 kernel(j+1) A2T
8899 !d        do iii=1,2
8900 !d          write (iout,'(3f10.5,5x,3f10.5)')
8901 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8902 !d        enddo
8903         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8904          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
8905          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8906 ! Following matrices are needed only for 6-th order cumulants
8907         IF (wcorr6.gt.0.0d0) THEN
8908         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8909          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
8910          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8911         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8912          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
8913          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8914          ADtEAderx(1,1,1,1,1,1))
8915         lprn=.false.
8916         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8917          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
8918          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8919          ADtEA1derx(1,1,1,1,1,1))
8920         ENDIF
8921 ! End 6-th order cumulants
8922 !d        lprn=.false.
8923 !d        if (lprn) then
8924 !d        write (2,*) 'In calc_eello6'
8925 !d        do iii=1,2
8926 !d          write (2,*) 'iii=',iii
8927 !d          do kkk=1,5
8928 !d            write (2,*) 'kkk=',kkk
8929 !d            do jjj=1,2
8930 !d              write (2,'(3(2f10.5),5x)')
8931 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8932 !d            enddo
8933 !d          enddo
8934 !d        enddo
8935 !d        endif
8936         call transpose2(EUgder(1,1,k),auxmat(1,1))
8937         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8938         call transpose2(EUg(1,1,k),auxmat(1,1))
8939         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8940         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8941         do iii=1,2
8942           do kkk=1,5
8943             do lll=1,3
8944               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8945                 EAEAderx(1,1,lll,kkk,iii,1))
8946             enddo
8947           enddo
8948         enddo
8949 ! A1T kernel(i+1) A2
8950         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8951          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
8952          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8953 ! Following matrices are needed only for 6-th order cumulants
8954         IF (wcorr6.gt.0.0d0) THEN
8955         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8956          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
8957          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8958         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8959          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
8960          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8961          ADtEAderx(1,1,1,1,1,2))
8962         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8963          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
8964          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8965          ADtEA1derx(1,1,1,1,1,2))
8966         ENDIF
8967 ! End 6-th order cumulants
8968         call transpose2(EUgder(1,1,l),auxmat(1,1))
8969         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8970         call transpose2(EUg(1,1,l),auxmat(1,1))
8971         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8972         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8973         do iii=1,2
8974           do kkk=1,5
8975             do lll=1,3
8976               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8977                 EAEAderx(1,1,lll,kkk,iii,2))
8978             enddo
8979           enddo
8980         enddo
8981 ! AEAb1 and AEAb2
8982 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8983 ! They are needed only when the fifth- or the sixth-order cumulants are
8984 ! indluded.
8985         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8986         call transpose2(AEA(1,1,1),auxmat(1,1))
8987         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8988         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8989         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8990         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8991         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8992         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8993         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8994         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8995         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8996         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8997         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8998         call transpose2(AEA(1,1,2),auxmat(1,1))
8999         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
9000         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9001         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9002         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9003         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
9004         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9005         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
9006         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
9007         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9008         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9009         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9010 ! Calculate the Cartesian derivatives of the vectors.
9011         do iii=1,2
9012           do kkk=1,5
9013             do lll=1,3
9014               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9015               call matvec2(auxmat(1,1),b1(1,iti),&
9016                 AEAb1derx(1,lll,kkk,iii,1,1))
9017               call matvec2(auxmat(1,1),Ub2(1,i),&
9018                 AEAb2derx(1,lll,kkk,iii,1,1))
9019               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9020                 AEAb1derx(1,lll,kkk,iii,2,1))
9021               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9022                 AEAb2derx(1,lll,kkk,iii,2,1))
9023               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9024               call matvec2(auxmat(1,1),b1(1,itj),&
9025                 AEAb1derx(1,lll,kkk,iii,1,2))
9026               call matvec2(auxmat(1,1),Ub2(1,j),&
9027                 AEAb2derx(1,lll,kkk,iii,1,2))
9028               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9029                 AEAb1derx(1,lll,kkk,iii,2,2))
9030               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
9031                 AEAb2derx(1,lll,kkk,iii,2,2))
9032             enddo
9033           enddo
9034         enddo
9035         ENDIF
9036 ! End vectors
9037       else
9038 ! Antiparallel orientation of the two CA-CA-CA frames.
9039         if (i.gt.1) then
9040           iti=itortyp(itype(i,1))
9041         else
9042           iti=ntortyp+1
9043         endif
9044         itk1=itortyp(itype(k+1,1))
9045         itl=itortyp(itype(l,1))
9046         itj=itortyp(itype(j,1))
9047         if (j.lt.nres-1) then
9048           itj1=itortyp(itype(j+1,1))
9049         else
9050           itj1=ntortyp+1
9051         endif
9052 ! A2 kernel(j-1)T A1T
9053         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9054          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
9055          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9056 ! Following matrices are needed only for 6-th order cumulants
9057         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9058            j.eq.i+4 .and. l.eq.i+3)) THEN
9059         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9060          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
9061          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9062         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9063          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
9064          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9065          ADtEAderx(1,1,1,1,1,1))
9066         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9067          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
9068          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9069          ADtEA1derx(1,1,1,1,1,1))
9070         ENDIF
9071 ! End 6-th order cumulants
9072         call transpose2(EUgder(1,1,k),auxmat(1,1))
9073         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9074         call transpose2(EUg(1,1,k),auxmat(1,1))
9075         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9076         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9077         do iii=1,2
9078           do kkk=1,5
9079             do lll=1,3
9080               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9081                 EAEAderx(1,1,lll,kkk,iii,1))
9082             enddo
9083           enddo
9084         enddo
9085 ! A2T kernel(i+1)T A1
9086         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9087          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
9088          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9089 ! Following matrices are needed only for 6-th order cumulants
9090         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9091            j.eq.i+4 .and. l.eq.i+3)) THEN
9092         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9093          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
9094          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9095         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9096          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
9097          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9098          ADtEAderx(1,1,1,1,1,2))
9099         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9100          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
9101          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9102          ADtEA1derx(1,1,1,1,1,2))
9103         ENDIF
9104 ! End 6-th order cumulants
9105         call transpose2(EUgder(1,1,j),auxmat(1,1))
9106         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9107         call transpose2(EUg(1,1,j),auxmat(1,1))
9108         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9109         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9110         do iii=1,2
9111           do kkk=1,5
9112             do lll=1,3
9113               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9114                 EAEAderx(1,1,lll,kkk,iii,2))
9115             enddo
9116           enddo
9117         enddo
9118 ! AEAb1 and AEAb2
9119 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9120 ! They are needed only when the fifth- or the sixth-order cumulants are
9121 ! indluded.
9122         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
9123           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9124         call transpose2(AEA(1,1,1),auxmat(1,1))
9125         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9126         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9127         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9128         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9129         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9130         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9131         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9132         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9133         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9134         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9135         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9136         call transpose2(AEA(1,1,2),auxmat(1,1))
9137         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
9138         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9139         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9140         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9141         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
9142         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9143         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
9144         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
9145         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9146         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9147         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9148 ! Calculate the Cartesian derivatives of the vectors.
9149         do iii=1,2
9150           do kkk=1,5
9151             do lll=1,3
9152               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9153               call matvec2(auxmat(1,1),b1(1,iti),&
9154                 AEAb1derx(1,lll,kkk,iii,1,1))
9155               call matvec2(auxmat(1,1),Ub2(1,i),&
9156                 AEAb2derx(1,lll,kkk,iii,1,1))
9157               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9158                 AEAb1derx(1,lll,kkk,iii,2,1))
9159               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9160                 AEAb2derx(1,lll,kkk,iii,2,1))
9161               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9162               call matvec2(auxmat(1,1),b1(1,itl),&
9163                 AEAb1derx(1,lll,kkk,iii,1,2))
9164               call matvec2(auxmat(1,1),Ub2(1,l),&
9165                 AEAb2derx(1,lll,kkk,iii,1,2))
9166               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
9167                 AEAb1derx(1,lll,kkk,iii,2,2))
9168               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
9169                 AEAb2derx(1,lll,kkk,iii,2,2))
9170             enddo
9171           enddo
9172         enddo
9173         ENDIF
9174 ! End vectors
9175       endif
9176       return
9177       end subroutine calc_eello
9178 !-----------------------------------------------------------------------------
9179       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
9180       use comm_kut
9181       implicit none
9182       integer :: nderg
9183       logical :: transp
9184       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
9185       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
9186       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
9187       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
9188       integer :: iii,kkk,lll
9189       integer :: jjj,mmm
9190 !el      logical :: lprn
9191 !el      common /kutas/ lprn
9192       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9193       do iii=1,nderg
9194         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
9195           AKAderg(1,1,iii))
9196       enddo
9197 !d      if (lprn) write (2,*) 'In kernel'
9198       do kkk=1,5
9199 !d        if (lprn) write (2,*) 'kkk=',kkk
9200         do lll=1,3
9201           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
9202             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9203 !d          if (lprn) then
9204 !d            write (2,*) 'lll=',lll
9205 !d            write (2,*) 'iii=1'
9206 !d            do jjj=1,2
9207 !d              write (2,'(3(2f10.5),5x)')
9208 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9209 !d            enddo
9210 !d          endif
9211           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
9212             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9213 !d          if (lprn) then
9214 !d            write (2,*) 'lll=',lll
9215 !d            write (2,*) 'iii=2'
9216 !d            do jjj=1,2
9217 !d              write (2,'(3(2f10.5),5x)')
9218 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9219 !d            enddo
9220 !d          endif
9221         enddo
9222       enddo
9223       return
9224       end subroutine kernel
9225 !-----------------------------------------------------------------------------
9226       real(kind=8) function eello4(i,j,k,l,jj,kk)
9227 !      implicit real*8 (a-h,o-z)
9228 !      include 'DIMENSIONS'
9229 !      include 'COMMON.IOUNITS'
9230 !      include 'COMMON.CHAIN'
9231 !      include 'COMMON.DERIV'
9232 !      include 'COMMON.INTERACT'
9233 !      include 'COMMON.CONTACTS'
9234 !      include 'COMMON.TORSION'
9235 !      include 'COMMON.VAR'
9236 !      include 'COMMON.GEO'
9237       real(kind=8),dimension(2,2) :: pizda
9238       real(kind=8),dimension(3) :: ggg1,ggg2
9239       real(kind=8) ::  eel4,glongij,glongkl
9240       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9241 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9242 !d        eello4=0.0d0
9243 !d        return
9244 !d      endif
9245 !d      print *,'eello4:',i,j,k,l,jj,kk
9246 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
9247 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
9248 !old      eij=facont_hb(jj,i)
9249 !old      ekl=facont_hb(kk,k)
9250 !old      ekont=eij*ekl
9251       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9252 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9253       gcorr_loc(k-1)=gcorr_loc(k-1) &
9254          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9255       if (l.eq.j+1) then
9256         gcorr_loc(l-1)=gcorr_loc(l-1) &
9257            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9258       else
9259         gcorr_loc(j-1)=gcorr_loc(j-1) &
9260            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9261       endif
9262       do iii=1,2
9263         do kkk=1,5
9264           do lll=1,3
9265             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
9266                               -EAEAderx(2,2,lll,kkk,iii,1)
9267 !d            derx(lll,kkk,iii)=0.0d0
9268           enddo
9269         enddo
9270       enddo
9271 !d      gcorr_loc(l-1)=0.0d0
9272 !d      gcorr_loc(j-1)=0.0d0
9273 !d      gcorr_loc(k-1)=0.0d0
9274 !d      eel4=1.0d0
9275 !d      write (iout,*)'Contacts have occurred for peptide groups',
9276 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9277 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9278       if (j.lt.nres-1) then
9279         j1=j+1
9280         j2=j-1
9281       else
9282         j1=j-1
9283         j2=j-2
9284       endif
9285       if (l.lt.nres-1) then
9286         l1=l+1
9287         l2=l-1
9288       else
9289         l1=l-1
9290         l2=l-2
9291       endif
9292       do ll=1,3
9293 !grad        ggg1(ll)=eel4*g_contij(ll,1)
9294 !grad        ggg2(ll)=eel4*g_contij(ll,2)
9295         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9296         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9297 !grad        ghalf=0.5d0*ggg1(ll)
9298         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9299         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9300         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9301         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9302         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9303         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9304 !grad        ghalf=0.5d0*ggg2(ll)
9305         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9306         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9307         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9308         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9309         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9310         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9311       enddo
9312 !grad      do m=i+1,j-1
9313 !grad        do ll=1,3
9314 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9315 !grad        enddo
9316 !grad      enddo
9317 !grad      do m=k+1,l-1
9318 !grad        do ll=1,3
9319 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9320 !grad        enddo
9321 !grad      enddo
9322 !grad      do m=i+2,j2
9323 !grad        do ll=1,3
9324 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9325 !grad        enddo
9326 !grad      enddo
9327 !grad      do m=k+2,l2
9328 !grad        do ll=1,3
9329 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9330 !grad        enddo
9331 !grad      enddo
9332 !d      do iii=1,nres-3
9333 !d        write (2,*) iii,gcorr_loc(iii)
9334 !d      enddo
9335       eello4=ekont*eel4
9336 !d      write (2,*) 'ekont',ekont
9337 !d      write (iout,*) 'eello4',ekont*eel4
9338       return
9339       end function eello4
9340 !-----------------------------------------------------------------------------
9341       real(kind=8) function eello5(i,j,k,l,jj,kk)
9342 !      implicit real*8 (a-h,o-z)
9343 !      include 'DIMENSIONS'
9344 !      include 'COMMON.IOUNITS'
9345 !      include 'COMMON.CHAIN'
9346 !      include 'COMMON.DERIV'
9347 !      include 'COMMON.INTERACT'
9348 !      include 'COMMON.CONTACTS'
9349 !      include 'COMMON.TORSION'
9350 !      include 'COMMON.VAR'
9351 !      include 'COMMON.GEO'
9352       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9353       real(kind=8),dimension(2) :: vv
9354       real(kind=8),dimension(3) :: ggg1,ggg2
9355       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
9356       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
9357       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
9358 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9359 !                                                                              C
9360 !                            Parallel chains                                   C
9361 !                                                                              C
9362 !          o             o                   o             o                   C
9363 !         /l\           / \             \   / \           / \   /              C
9364 !        /   \         /   \             \ /   \         /   \ /               C
9365 !       j| o |l1       | o |                o| o |         | o |o                C
9366 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9367 !      \i/   \         /   \ /             /   \         /   \                 C
9368 !       o    k1             o                                                  C
9369 !         (I)          (II)                (III)          (IV)                 C
9370 !                                                                              C
9371 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9372 !                                                                              C
9373 !                            Antiparallel chains                               C
9374 !                                                                              C
9375 !          o             o                   o             o                   C
9376 !         /j\           / \             \   / \           / \   /              C
9377 !        /   \         /   \             \ /   \         /   \ /               C
9378 !      j1| o |l        | o |                o| o |         | o |o                C
9379 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9380 !      \i/   \         /   \ /             /   \         /   \                 C
9381 !       o     k1            o                                                  C
9382 !         (I)          (II)                (III)          (IV)                 C
9383 !                                                                              C
9384 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9385 !                                                                              C
9386 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
9387 !                                                                              C
9388 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9389 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9390 !d        eello5=0.0d0
9391 !d        return
9392 !d      endif
9393 !d      write (iout,*)
9394 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9395 !d     &   ' and',k,l
9396       itk=itortyp(itype(k,1))
9397       itl=itortyp(itype(l,1))
9398       itj=itortyp(itype(j,1))
9399       eello5_1=0.0d0
9400       eello5_2=0.0d0
9401       eello5_3=0.0d0
9402       eello5_4=0.0d0
9403 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9404 !d     &   eel5_3_num,eel5_4_num)
9405       do iii=1,2
9406         do kkk=1,5
9407           do lll=1,3
9408             derx(lll,kkk,iii)=0.0d0
9409           enddo
9410         enddo
9411       enddo
9412 !d      eij=facont_hb(jj,i)
9413 !d      ekl=facont_hb(kk,k)
9414 !d      ekont=eij*ekl
9415 !d      write (iout,*)'Contacts have occurred for peptide groups',
9416 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
9417 !d      goto 1111
9418 ! Contribution from the graph I.
9419 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9420 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9421       call transpose2(EUg(1,1,k),auxmat(1,1))
9422       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9423       vv(1)=pizda(1,1)-pizda(2,2)
9424       vv(2)=pizda(1,2)+pizda(2,1)
9425       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
9426        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9427 ! Explicit gradient in virtual-dihedral angles.
9428       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
9429        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
9430        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9431       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9432       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9433       vv(1)=pizda(1,1)-pizda(2,2)
9434       vv(2)=pizda(1,2)+pizda(2,1)
9435       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9436        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
9437        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9438       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9439       vv(1)=pizda(1,1)-pizda(2,2)
9440       vv(2)=pizda(1,2)+pizda(2,1)
9441       if (l.eq.j+1) then
9442         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9443          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9444          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9445       else
9446         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9447          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9448          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9449       endif
9450 ! Cartesian gradient
9451       do iii=1,2
9452         do kkk=1,5
9453           do lll=1,3
9454             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9455               pizda(1,1))
9456             vv(1)=pizda(1,1)-pizda(2,2)
9457             vv(2)=pizda(1,2)+pizda(2,1)
9458             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9459              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
9460              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9461           enddo
9462         enddo
9463       enddo
9464 !      goto 1112
9465 !1111  continue
9466 ! Contribution from graph II
9467       call transpose2(EE(1,1,itk),auxmat(1,1))
9468       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9469       vv(1)=pizda(1,1)+pizda(2,2)
9470       vv(2)=pizda(2,1)-pizda(1,2)
9471       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
9472        -0.5d0*scalar2(vv(1),Ctobr(1,k))
9473 ! Explicit gradient in virtual-dihedral angles.
9474       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9475        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9476       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9477       vv(1)=pizda(1,1)+pizda(2,2)
9478       vv(2)=pizda(2,1)-pizda(1,2)
9479       if (l.eq.j+1) then
9480         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9481          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9482          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9483       else
9484         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9485          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9486          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9487       endif
9488 ! Cartesian gradient
9489       do iii=1,2
9490         do kkk=1,5
9491           do lll=1,3
9492             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9493               pizda(1,1))
9494             vv(1)=pizda(1,1)+pizda(2,2)
9495             vv(2)=pizda(2,1)-pizda(1,2)
9496             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9497              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
9498              -0.5d0*scalar2(vv(1),Ctobr(1,k))
9499           enddo
9500         enddo
9501       enddo
9502 !d      goto 1112
9503 !d1111  continue
9504       if (l.eq.j+1) then
9505 !d        goto 1110
9506 ! Parallel orientation
9507 ! Contribution from graph III
9508         call transpose2(EUg(1,1,l),auxmat(1,1))
9509         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9510         vv(1)=pizda(1,1)-pizda(2,2)
9511         vv(2)=pizda(1,2)+pizda(2,1)
9512         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
9513          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9514 ! Explicit gradient in virtual-dihedral angles.
9515         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9516          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
9517          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9518         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9519         vv(1)=pizda(1,1)-pizda(2,2)
9520         vv(2)=pizda(1,2)+pizda(2,1)
9521         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9522          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
9523          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9524         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9525         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9526         vv(1)=pizda(1,1)-pizda(2,2)
9527         vv(2)=pizda(1,2)+pizda(2,1)
9528         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9529          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
9530          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9531 ! Cartesian gradient
9532         do iii=1,2
9533           do kkk=1,5
9534             do lll=1,3
9535               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9536                 pizda(1,1))
9537               vv(1)=pizda(1,1)-pizda(2,2)
9538               vv(2)=pizda(1,2)+pizda(2,1)
9539               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9540                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
9541                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9542             enddo
9543           enddo
9544         enddo
9545 !d        goto 1112
9546 ! Contribution from graph IV
9547 !d1110    continue
9548         call transpose2(EE(1,1,itl),auxmat(1,1))
9549         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9550         vv(1)=pizda(1,1)+pizda(2,2)
9551         vv(2)=pizda(2,1)-pizda(1,2)
9552         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
9553          -0.5d0*scalar2(vv(1),Ctobr(1,l))
9554 ! Explicit gradient in virtual-dihedral angles.
9555         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9556          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9557         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9558         vv(1)=pizda(1,1)+pizda(2,2)
9559         vv(2)=pizda(2,1)-pizda(1,2)
9560         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9561          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
9562          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9563 ! Cartesian gradient
9564         do iii=1,2
9565           do kkk=1,5
9566             do lll=1,3
9567               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9568                 pizda(1,1))
9569               vv(1)=pizda(1,1)+pizda(2,2)
9570               vv(2)=pizda(2,1)-pizda(1,2)
9571               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9572                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
9573                -0.5d0*scalar2(vv(1),Ctobr(1,l))
9574             enddo
9575           enddo
9576         enddo
9577       else
9578 ! Antiparallel orientation
9579 ! Contribution from graph III
9580 !        goto 1110
9581         call transpose2(EUg(1,1,j),auxmat(1,1))
9582         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9583         vv(1)=pizda(1,1)-pizda(2,2)
9584         vv(2)=pizda(1,2)+pizda(2,1)
9585         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
9586          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9587 ! Explicit gradient in virtual-dihedral angles.
9588         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9589          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
9590          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9591         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9592         vv(1)=pizda(1,1)-pizda(2,2)
9593         vv(2)=pizda(1,2)+pizda(2,1)
9594         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9595          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
9596          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9597         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9598         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9599         vv(1)=pizda(1,1)-pizda(2,2)
9600         vv(2)=pizda(1,2)+pizda(2,1)
9601         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9602          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
9603          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9604 ! Cartesian gradient
9605         do iii=1,2
9606           do kkk=1,5
9607             do lll=1,3
9608               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9609                 pizda(1,1))
9610               vv(1)=pizda(1,1)-pizda(2,2)
9611               vv(2)=pizda(1,2)+pizda(2,1)
9612               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9613                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
9614                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9615             enddo
9616           enddo
9617         enddo
9618 !d        goto 1112
9619 ! Contribution from graph IV
9620 1110    continue
9621         call transpose2(EE(1,1,itj),auxmat(1,1))
9622         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9623         vv(1)=pizda(1,1)+pizda(2,2)
9624         vv(2)=pizda(2,1)-pizda(1,2)
9625         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
9626          -0.5d0*scalar2(vv(1),Ctobr(1,j))
9627 ! Explicit gradient in virtual-dihedral angles.
9628         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9629          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9630         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9631         vv(1)=pizda(1,1)+pizda(2,2)
9632         vv(2)=pizda(2,1)-pizda(1,2)
9633         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9634          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
9635          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9636 ! Cartesian gradient
9637         do iii=1,2
9638           do kkk=1,5
9639             do lll=1,3
9640               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9641                 pizda(1,1))
9642               vv(1)=pizda(1,1)+pizda(2,2)
9643               vv(2)=pizda(2,1)-pizda(1,2)
9644               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9645                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
9646                -0.5d0*scalar2(vv(1),Ctobr(1,j))
9647             enddo
9648           enddo
9649         enddo
9650       endif
9651 1112  continue
9652       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9653 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9654 !d        write (2,*) 'ijkl',i,j,k,l
9655 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9656 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9657 !d      endif
9658 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9659 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9660 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9661 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9662       if (j.lt.nres-1) then
9663         j1=j+1
9664         j2=j-1
9665       else
9666         j1=j-1
9667         j2=j-2
9668       endif
9669       if (l.lt.nres-1) then
9670         l1=l+1
9671         l2=l-1
9672       else
9673         l1=l-1
9674         l2=l-2
9675       endif
9676 !d      eij=1.0d0
9677 !d      ekl=1.0d0
9678 !d      ekont=1.0d0
9679 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9680 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
9681 !        summed up outside the subrouine as for the other subroutines
9682 !        handling long-range interactions. The old code is commented out
9683 !        with "cgrad" to keep track of changes.
9684       do ll=1,3
9685 !grad        ggg1(ll)=eel5*g_contij(ll,1)
9686 !grad        ggg2(ll)=eel5*g_contij(ll,2)
9687         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9688         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9689 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9690 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9691 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9692 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9693 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9694 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9695 !     &   gradcorr5ij,
9696 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9697 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9698 !grad        ghalf=0.5d0*ggg1(ll)
9699 !d        ghalf=0.0d0
9700         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9701         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9702         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9703         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9704         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9705         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9706 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9707 !grad        ghalf=0.5d0*ggg2(ll)
9708         ghalf=0.0d0
9709         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9710         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9711         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9712         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9713         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9714         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9715       enddo
9716 !d      goto 1112
9717 !grad      do m=i+1,j-1
9718 !grad        do ll=1,3
9719 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9720 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9721 !grad        enddo
9722 !grad      enddo
9723 !grad      do m=k+1,l-1
9724 !grad        do ll=1,3
9725 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9726 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9727 !grad        enddo
9728 !grad      enddo
9729 !1112  continue
9730 !grad      do m=i+2,j2
9731 !grad        do ll=1,3
9732 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9733 !grad        enddo
9734 !grad      enddo
9735 !grad      do m=k+2,l2
9736 !grad        do ll=1,3
9737 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9738 !grad        enddo
9739 !grad      enddo
9740 !d      do iii=1,nres-3
9741 !d        write (2,*) iii,g_corr5_loc(iii)
9742 !d      enddo
9743       eello5=ekont*eel5
9744 !d      write (2,*) 'ekont',ekont
9745 !d      write (iout,*) 'eello5',ekont*eel5
9746       return
9747       end function eello5
9748 !-----------------------------------------------------------------------------
9749       real(kind=8) function eello6(i,j,k,l,jj,kk)
9750 !      implicit real*8 (a-h,o-z)
9751 !      include 'DIMENSIONS'
9752 !      include 'COMMON.IOUNITS'
9753 !      include 'COMMON.CHAIN'
9754 !      include 'COMMON.DERIV'
9755 !      include 'COMMON.INTERACT'
9756 !      include 'COMMON.CONTACTS'
9757 !      include 'COMMON.TORSION'
9758 !      include 'COMMON.VAR'
9759 !      include 'COMMON.GEO'
9760 !      include 'COMMON.FFIELD'
9761       real(kind=8),dimension(3) :: ggg1,ggg2
9762       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9763                    eello6_6,eel6
9764       real(kind=8) :: gradcorr6ij,gradcorr6kl
9765       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9766 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9767 !d        eello6=0.0d0
9768 !d        return
9769 !d      endif
9770 !d      write (iout,*)
9771 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9772 !d     &   ' and',k,l
9773       eello6_1=0.0d0
9774       eello6_2=0.0d0
9775       eello6_3=0.0d0
9776       eello6_4=0.0d0
9777       eello6_5=0.0d0
9778       eello6_6=0.0d0
9779 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9780 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9781       do iii=1,2
9782         do kkk=1,5
9783           do lll=1,3
9784             derx(lll,kkk,iii)=0.0d0
9785           enddo
9786         enddo
9787       enddo
9788 !d      eij=facont_hb(jj,i)
9789 !d      ekl=facont_hb(kk,k)
9790 !d      ekont=eij*ekl
9791 !d      eij=1.0d0
9792 !d      ekl=1.0d0
9793 !d      ekont=1.0d0
9794       if (l.eq.j+1) then
9795         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9796         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9797         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9798         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9799         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9800         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9801       else
9802         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9803         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9804         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9805         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9806         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9807           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9808         else
9809           eello6_5=0.0d0
9810         endif
9811         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9812       endif
9813 ! If turn contributions are considered, they will be handled separately.
9814       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9815 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9816 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9817 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9818 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9819 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9820 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9821 !d      goto 1112
9822       if (j.lt.nres-1) then
9823         j1=j+1
9824         j2=j-1
9825       else
9826         j1=j-1
9827         j2=j-2
9828       endif
9829       if (l.lt.nres-1) then
9830         l1=l+1
9831         l2=l-1
9832       else
9833         l1=l-1
9834         l2=l-2
9835       endif
9836       do ll=1,3
9837 !grad        ggg1(ll)=eel6*g_contij(ll,1)
9838 !grad        ggg2(ll)=eel6*g_contij(ll,2)
9839 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9840 !grad        ghalf=0.5d0*ggg1(ll)
9841 !d        ghalf=0.0d0
9842         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9843         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9844         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9845         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9846         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9847         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9848         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9849         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9850 !grad        ghalf=0.5d0*ggg2(ll)
9851 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9852 !d        ghalf=0.0d0
9853         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9854         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9855         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9856         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9857         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9858         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9859       enddo
9860 !d      goto 1112
9861 !grad      do m=i+1,j-1
9862 !grad        do ll=1,3
9863 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9864 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9865 !grad        enddo
9866 !grad      enddo
9867 !grad      do m=k+1,l-1
9868 !grad        do ll=1,3
9869 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9870 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9871 !grad        enddo
9872 !grad      enddo
9873 !grad1112  continue
9874 !grad      do m=i+2,j2
9875 !grad        do ll=1,3
9876 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9877 !grad        enddo
9878 !grad      enddo
9879 !grad      do m=k+2,l2
9880 !grad        do ll=1,3
9881 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9882 !grad        enddo
9883 !grad      enddo
9884 !d      do iii=1,nres-3
9885 !d        write (2,*) iii,g_corr6_loc(iii)
9886 !d      enddo
9887       eello6=ekont*eel6
9888 !d      write (2,*) 'ekont',ekont
9889 !d      write (iout,*) 'eello6',ekont*eel6
9890       return
9891       end function eello6
9892 !-----------------------------------------------------------------------------
9893       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
9894       use comm_kut
9895 !      implicit real*8 (a-h,o-z)
9896 !      include 'DIMENSIONS'
9897 !      include 'COMMON.IOUNITS'
9898 !      include 'COMMON.CHAIN'
9899 !      include 'COMMON.DERIV'
9900 !      include 'COMMON.INTERACT'
9901 !      include 'COMMON.CONTACTS'
9902 !      include 'COMMON.TORSION'
9903 !      include 'COMMON.VAR'
9904 !      include 'COMMON.GEO'
9905       real(kind=8),dimension(2) :: vv,vv1
9906       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
9907       logical :: swap
9908 !el      logical :: lprn
9909 !el      common /kutas/ lprn
9910       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
9911       real(kind=8) :: s1,s2,s3,s4,s5
9912 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9913 !                                                                              C
9914 !      Parallel       Antiparallel                                             C
9915 !                                                                              C
9916 !          o             o                                                     C
9917 !         /l\           /j\                                                    C
9918 !        /   \         /   \                                                   C
9919 !       /| o |         | o |\                                                  C
9920 !     \ j|/k\|  /   \  |/k\|l /                                                C
9921 !      \ /   \ /     \ /   \ /                                                 C
9922 !       o     o       o     o                                                  C
9923 !       i             i                                                        C
9924 !                                                                              C
9925 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9926       itk=itortyp(itype(k,1))
9927       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9928       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9929       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9930       call transpose2(EUgC(1,1,k),auxmat(1,1))
9931       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9932       vv1(1)=pizda1(1,1)-pizda1(2,2)
9933       vv1(2)=pizda1(1,2)+pizda1(2,1)
9934       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9935       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
9936       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
9937       s5=scalar2(vv(1),Dtobr2(1,i))
9938 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9939       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9940       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
9941        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
9942        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
9943        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
9944        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
9945        +scalar2(vv(1),Dtobr2der(1,i)))
9946       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9947       vv1(1)=pizda1(1,1)-pizda1(2,2)
9948       vv1(2)=pizda1(1,2)+pizda1(2,1)
9949       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
9950       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
9951       if (l.eq.j+1) then
9952         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
9953        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9954        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9955        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9956        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9957       else
9958         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
9959        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9960        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9961        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9962        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9963       endif
9964       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9965       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9966       vv1(1)=pizda1(1,1)-pizda1(2,2)
9967       vv1(2)=pizda1(1,2)+pizda1(2,1)
9968       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
9969        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
9970        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
9971        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9972       do iii=1,2
9973         if (swap) then
9974           ind=3-iii
9975         else
9976           ind=iii
9977         endif
9978         do kkk=1,5
9979           do lll=1,3
9980             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9981             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9982             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9983             call transpose2(EUgC(1,1,k),auxmat(1,1))
9984             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9985               pizda1(1,1))
9986             vv1(1)=pizda1(1,1)-pizda1(2,2)
9987             vv1(2)=pizda1(1,2)+pizda1(2,1)
9988             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9989             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
9990              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
9991             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
9992              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
9993             s5=scalar2(vv(1),Dtobr2(1,i))
9994             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9995           enddo
9996         enddo
9997       enddo
9998       return
9999       end function eello6_graph1
10000 !-----------------------------------------------------------------------------
10001       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
10002       use comm_kut
10003 !      implicit real*8 (a-h,o-z)
10004 !      include 'DIMENSIONS'
10005 !      include 'COMMON.IOUNITS'
10006 !      include 'COMMON.CHAIN'
10007 !      include 'COMMON.DERIV'
10008 !      include 'COMMON.INTERACT'
10009 !      include 'COMMON.CONTACTS'
10010 !      include 'COMMON.TORSION'
10011 !      include 'COMMON.VAR'
10012 !      include 'COMMON.GEO'
10013       logical :: swap
10014       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
10015       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10016 !el      logical :: lprn
10017 !el      common /kutas/ lprn
10018       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
10019       real(kind=8) :: s2,s3,s4
10020 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10021 !                                                                              C
10022 !      Parallel       Antiparallel                                             C
10023 !                                                                              C
10024 !          o             o                                                     C
10025 !     \   /l\           /j\   /                                                C
10026 !      \ /   \         /   \ /                                                 C
10027 !       o| o |         | o |o                                                  C
10028 !     \ j|/k\|      \  |/k\|l                                                  C
10029 !      \ /   \       \ /   \                                                   C
10030 !       o             o                                                        C
10031 !       i             i                                                        C
10032 !                                                                              C
10033 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10034 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10035 ! AL 7/4/01 s1 would occur in the sixth-order moment,
10036 !           but not in a cluster cumulant
10037 #ifdef MOMENT
10038       s1=dip(1,jj,i)*dip(1,kk,k)
10039 #endif
10040       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10041       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10042       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10043       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10044       call transpose2(EUg(1,1,k),auxmat(1,1))
10045       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10046       vv(1)=pizda(1,1)-pizda(2,2)
10047       vv(2)=pizda(1,2)+pizda(2,1)
10048       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10049 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10050 #ifdef MOMENT
10051       eello6_graph2=-(s1+s2+s3+s4)
10052 #else
10053       eello6_graph2=-(s2+s3+s4)
10054 #endif
10055 !      eello6_graph2=-s3
10056 ! Derivatives in gamma(i-1)
10057       if (i.gt.1) then
10058 #ifdef MOMENT
10059         s1=dipderg(1,jj,i)*dip(1,kk,k)
10060 #endif
10061         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10062         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10063         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10064         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10065 #ifdef MOMENT
10066         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10067 #else
10068         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10069 #endif
10070 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10071       endif
10072 ! Derivatives in gamma(k-1)
10073 #ifdef MOMENT
10074       s1=dip(1,jj,i)*dipderg(1,kk,k)
10075 #endif
10076       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10077       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10078       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10079       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10080       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10081       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10082       vv(1)=pizda(1,1)-pizda(2,2)
10083       vv(2)=pizda(1,2)+pizda(2,1)
10084       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10085 #ifdef MOMENT
10086       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10087 #else
10088       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10089 #endif
10090 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10091 ! Derivatives in gamma(j-1) or gamma(l-1)
10092       if (j.gt.1) then
10093 #ifdef MOMENT
10094         s1=dipderg(3,jj,i)*dip(1,kk,k)
10095 #endif
10096         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10097         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10098         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10099         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10100         vv(1)=pizda(1,1)-pizda(2,2)
10101         vv(2)=pizda(1,2)+pizda(2,1)
10102         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10103 #ifdef MOMENT
10104         if (swap) then
10105           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10106         else
10107           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10108         endif
10109 #endif
10110         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10111 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10112       endif
10113 ! Derivatives in gamma(l-1) or gamma(j-1)
10114       if (l.gt.1) then
10115 #ifdef MOMENT
10116         s1=dip(1,jj,i)*dipderg(3,kk,k)
10117 #endif
10118         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10119         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10120         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10121         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10122         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10123         vv(1)=pizda(1,1)-pizda(2,2)
10124         vv(2)=pizda(1,2)+pizda(2,1)
10125         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10126 #ifdef MOMENT
10127         if (swap) then
10128           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10129         else
10130           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10131         endif
10132 #endif
10133         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10134 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10135       endif
10136 ! Cartesian derivatives.
10137       if (lprn) then
10138         write (2,*) 'In eello6_graph2'
10139         do iii=1,2
10140           write (2,*) 'iii=',iii
10141           do kkk=1,5
10142             write (2,*) 'kkk=',kkk
10143             do jjj=1,2
10144               write (2,'(3(2f10.5),5x)') &
10145               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10146             enddo
10147           enddo
10148         enddo
10149       endif
10150       do iii=1,2
10151         do kkk=1,5
10152           do lll=1,3
10153 #ifdef MOMENT
10154             if (iii.eq.1) then
10155               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10156             else
10157               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10158             endif
10159 #endif
10160             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
10161               auxvec(1))
10162             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10163             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
10164               auxvec(1))
10165             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10166             call transpose2(EUg(1,1,k),auxmat(1,1))
10167             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
10168               pizda(1,1))
10169             vv(1)=pizda(1,1)-pizda(2,2)
10170             vv(2)=pizda(1,2)+pizda(2,1)
10171             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10172 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10173 #ifdef MOMENT
10174             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10175 #else
10176             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10177 #endif
10178             if (swap) then
10179               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10180             else
10181               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10182             endif
10183           enddo
10184         enddo
10185       enddo
10186       return
10187       end function eello6_graph2
10188 !-----------------------------------------------------------------------------
10189       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
10190 !      implicit real*8 (a-h,o-z)
10191 !      include 'DIMENSIONS'
10192 !      include 'COMMON.IOUNITS'
10193 !      include 'COMMON.CHAIN'
10194 !      include 'COMMON.DERIV'
10195 !      include 'COMMON.INTERACT'
10196 !      include 'COMMON.CONTACTS'
10197 !      include 'COMMON.TORSION'
10198 !      include 'COMMON.VAR'
10199 !      include 'COMMON.GEO'
10200       real(kind=8),dimension(2) :: vv,auxvec
10201       real(kind=8),dimension(2,2) :: pizda,auxmat
10202       logical :: swap
10203       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
10204       real(kind=8) :: s1,s2,s3,s4
10205 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10206 !                                                                              C
10207 !      Parallel       Antiparallel                                             C
10208 !                                                                              C
10209 !          o             o                                                     C
10210 !         /l\   /   \   /j\                                                    C
10211 !        /   \ /     \ /   \                                                   C
10212 !       /| o |o       o| o |\                                                  C
10213 !       j|/k\|  /      |/k\|l /                                                C
10214 !        /   \ /       /   \ /                                                 C
10215 !       /     o       /     o                                                  C
10216 !       i             i                                                        C
10217 !                                                                              C
10218 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10219 !
10220 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10221 !           energy moment and not to the cluster cumulant.
10222       iti=itortyp(itype(i,1))
10223       if (j.lt.nres-1) then
10224         itj1=itortyp(itype(j+1,1))
10225       else
10226         itj1=ntortyp+1
10227       endif
10228       itk=itortyp(itype(k,1))
10229       itk1=itortyp(itype(k+1,1))
10230       if (l.lt.nres-1) then
10231         itl1=itortyp(itype(l+1,1))
10232       else
10233         itl1=ntortyp+1
10234       endif
10235 #ifdef MOMENT
10236       s1=dip(4,jj,i)*dip(4,kk,k)
10237 #endif
10238       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
10239       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10240       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
10241       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10242       call transpose2(EE(1,1,itk),auxmat(1,1))
10243       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10244       vv(1)=pizda(1,1)+pizda(2,2)
10245       vv(2)=pizda(2,1)-pizda(1,2)
10246       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10247 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10248 !d     & "sum",-(s2+s3+s4)
10249 #ifdef MOMENT
10250       eello6_graph3=-(s1+s2+s3+s4)
10251 #else
10252       eello6_graph3=-(s2+s3+s4)
10253 #endif
10254 !      eello6_graph3=-s4
10255 ! Derivatives in gamma(k-1)
10256       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
10257       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10258       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10259       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10260 ! Derivatives in gamma(l-1)
10261       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
10262       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10263       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10264       vv(1)=pizda(1,1)+pizda(2,2)
10265       vv(2)=pizda(2,1)-pizda(1,2)
10266       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10267       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10268 ! Cartesian derivatives.
10269       do iii=1,2
10270         do kkk=1,5
10271           do lll=1,3
10272 #ifdef MOMENT
10273             if (iii.eq.1) then
10274               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10275             else
10276               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10277             endif
10278 #endif
10279             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
10280               auxvec(1))
10281             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10282             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
10283               auxvec(1))
10284             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10285             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
10286               pizda(1,1))
10287             vv(1)=pizda(1,1)+pizda(2,2)
10288             vv(2)=pizda(2,1)-pizda(1,2)
10289             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10290 #ifdef MOMENT
10291             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10292 #else
10293             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10294 #endif
10295             if (swap) then
10296               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10297             else
10298               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10299             endif
10300 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10301           enddo
10302         enddo
10303       enddo
10304       return
10305       end function eello6_graph3
10306 !-----------------------------------------------------------------------------
10307       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10308 !      implicit real*8 (a-h,o-z)
10309 !      include 'DIMENSIONS'
10310 !      include 'COMMON.IOUNITS'
10311 !      include 'COMMON.CHAIN'
10312 !      include 'COMMON.DERIV'
10313 !      include 'COMMON.INTERACT'
10314 !      include 'COMMON.CONTACTS'
10315 !      include 'COMMON.TORSION'
10316 !      include 'COMMON.VAR'
10317 !      include 'COMMON.GEO'
10318 !      include 'COMMON.FFIELD'
10319       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
10320       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10321       logical :: swap
10322       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
10323               iii,kkk,lll
10324       real(kind=8) :: s1,s2,s3,s4
10325 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10326 !                                                                              C
10327 !      Parallel       Antiparallel                                             C
10328 !                                                                              C
10329 !          o             o                                                     C
10330 !         /l\   /   \   /j\                                                    C
10331 !        /   \ /     \ /   \                                                   C
10332 !       /| o |o       o| o |\                                                  C
10333 !     \ j|/k\|      \  |/k\|l                                                  C
10334 !      \ /   \       \ /   \                                                   C
10335 !       o     \       o     \                                                  C
10336 !       i             i                                                        C
10337 !                                                                              C
10338 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10339 !
10340 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10341 !           energy moment and not to the cluster cumulant.
10342 !d      write (2,*) 'eello_graph4: wturn6',wturn6
10343       iti=itortyp(itype(i,1))
10344       itj=itortyp(itype(j,1))
10345       if (j.lt.nres-1) then
10346         itj1=itortyp(itype(j+1,1))
10347       else
10348         itj1=ntortyp+1
10349       endif
10350       itk=itortyp(itype(k,1))
10351       if (k.lt.nres-1) then
10352         itk1=itortyp(itype(k+1,1))
10353       else
10354         itk1=ntortyp+1
10355       endif
10356       itl=itortyp(itype(l,1))
10357       if (l.lt.nres-1) then
10358         itl1=itortyp(itype(l+1,1))
10359       else
10360         itl1=ntortyp+1
10361       endif
10362 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10363 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10364 !d     & ' itl',itl,' itl1',itl1
10365 #ifdef MOMENT
10366       if (imat.eq.1) then
10367         s1=dip(3,jj,i)*dip(3,kk,k)
10368       else
10369         s1=dip(2,jj,j)*dip(2,kk,l)
10370       endif
10371 #endif
10372       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10373       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10374       if (j.eq.l+1) then
10375         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
10376         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10377       else
10378         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
10379         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10380       endif
10381       call transpose2(EUg(1,1,k),auxmat(1,1))
10382       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10383       vv(1)=pizda(1,1)-pizda(2,2)
10384       vv(2)=pizda(2,1)+pizda(1,2)
10385       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10386 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10387 #ifdef MOMENT
10388       eello6_graph4=-(s1+s2+s3+s4)
10389 #else
10390       eello6_graph4=-(s2+s3+s4)
10391 #endif
10392 ! Derivatives in gamma(i-1)
10393       if (i.gt.1) then
10394 #ifdef MOMENT
10395         if (imat.eq.1) then
10396           s1=dipderg(2,jj,i)*dip(3,kk,k)
10397         else
10398           s1=dipderg(4,jj,j)*dip(2,kk,l)
10399         endif
10400 #endif
10401         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10402         if (j.eq.l+1) then
10403           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
10404           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10405         else
10406           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
10407           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10408         endif
10409         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10410         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10411 !d          write (2,*) 'turn6 derivatives'
10412 #ifdef MOMENT
10413           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10414 #else
10415           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10416 #endif
10417         else
10418 #ifdef MOMENT
10419           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10420 #else
10421           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10422 #endif
10423         endif
10424       endif
10425 ! Derivatives in gamma(k-1)
10426 #ifdef MOMENT
10427       if (imat.eq.1) then
10428         s1=dip(3,jj,i)*dipderg(2,kk,k)
10429       else
10430         s1=dip(2,jj,j)*dipderg(4,kk,l)
10431       endif
10432 #endif
10433       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10434       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10435       if (j.eq.l+1) then
10436         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
10437         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10438       else
10439         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
10440         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10441       endif
10442       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10443       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10444       vv(1)=pizda(1,1)-pizda(2,2)
10445       vv(2)=pizda(2,1)+pizda(1,2)
10446       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10447       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10448 #ifdef MOMENT
10449         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10450 #else
10451         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10452 #endif
10453       else
10454 #ifdef MOMENT
10455         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10456 #else
10457         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10458 #endif
10459       endif
10460 ! Derivatives in gamma(j-1) or gamma(l-1)
10461       if (l.eq.j+1 .and. l.gt.1) then
10462         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10463         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10464         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10465         vv(1)=pizda(1,1)-pizda(2,2)
10466         vv(2)=pizda(2,1)+pizda(1,2)
10467         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10468         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10469       else if (j.gt.1) then
10470         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10471         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10472         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10473         vv(1)=pizda(1,1)-pizda(2,2)
10474         vv(2)=pizda(2,1)+pizda(1,2)
10475         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10476         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10477           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10478         else
10479           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10480         endif
10481       endif
10482 ! Cartesian derivatives.
10483       do iii=1,2
10484         do kkk=1,5
10485           do lll=1,3
10486 #ifdef MOMENT
10487             if (iii.eq.1) then
10488               if (imat.eq.1) then
10489                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10490               else
10491                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10492               endif
10493             else
10494               if (imat.eq.1) then
10495                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10496               else
10497                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10498               endif
10499             endif
10500 #endif
10501             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
10502               auxvec(1))
10503             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10504             if (j.eq.l+1) then
10505               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10506                 b1(1,itj1),auxvec(1))
10507               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
10508             else
10509               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10510                 b1(1,itl1),auxvec(1))
10511               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
10512             endif
10513             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10514               pizda(1,1))
10515             vv(1)=pizda(1,1)-pizda(2,2)
10516             vv(2)=pizda(2,1)+pizda(1,2)
10517             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10518             if (swap) then
10519               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10520 #ifdef MOMENT
10521                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10522                    -(s1+s2+s4)
10523 #else
10524                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10525                    -(s2+s4)
10526 #endif
10527                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10528               else
10529 #ifdef MOMENT
10530                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10531 #else
10532                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10533 #endif
10534                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10535               endif
10536             else
10537 #ifdef MOMENT
10538               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10539 #else
10540               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10541 #endif
10542               if (l.eq.j+1) then
10543                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10544               else
10545                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10546               endif
10547             endif
10548           enddo
10549         enddo
10550       enddo
10551       return
10552       end function eello6_graph4
10553 !-----------------------------------------------------------------------------
10554       real(kind=8) function eello_turn6(i,jj,kk)
10555 !      implicit real*8 (a-h,o-z)
10556 !      include 'DIMENSIONS'
10557 !      include 'COMMON.IOUNITS'
10558 !      include 'COMMON.CHAIN'
10559 !      include 'COMMON.DERIV'
10560 !      include 'COMMON.INTERACT'
10561 !      include 'COMMON.CONTACTS'
10562 !      include 'COMMON.TORSION'
10563 !      include 'COMMON.VAR'
10564 !      include 'COMMON.GEO'
10565       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
10566       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
10567       real(kind=8),dimension(3) :: ggg1,ggg2
10568       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
10569       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
10570 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10571 !           the respective energy moment and not to the cluster cumulant.
10572 !el local variables
10573       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
10574       integer :: j1,j2,l1,l2,ll
10575       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
10576       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
10577       s1=0.0d0
10578       s8=0.0d0
10579       s13=0.0d0
10580 !
10581       eello_turn6=0.0d0
10582       j=i+4
10583       k=i+1
10584       l=i+3
10585       iti=itortyp(itype(i,1))
10586       itk=itortyp(itype(k,1))
10587       itk1=itortyp(itype(k+1,1))
10588       itl=itortyp(itype(l,1))
10589       itj=itortyp(itype(j,1))
10590 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10591 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
10592 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10593 !d        eello6=0.0d0
10594 !d        return
10595 !d      endif
10596 !d      write (iout,*)
10597 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10598 !d     &   ' and',k,l
10599 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
10600       do iii=1,2
10601         do kkk=1,5
10602           do lll=1,3
10603             derx_turn(lll,kkk,iii)=0.0d0
10604           enddo
10605         enddo
10606       enddo
10607 !d      eij=1.0d0
10608 !d      ekl=1.0d0
10609 !d      ekont=1.0d0
10610       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10611 !d      eello6_5=0.0d0
10612 !d      write (2,*) 'eello6_5',eello6_5
10613 #ifdef MOMENT
10614       call transpose2(AEA(1,1,1),auxmat(1,1))
10615       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10616       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
10617       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10618 #endif
10619       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10620       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10621       s2 = scalar2(b1(1,itk),vtemp1(1))
10622 #ifdef MOMENT
10623       call transpose2(AEA(1,1,2),atemp(1,1))
10624       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10625       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10626       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10627 #endif
10628       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10629       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10630       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10631 #ifdef MOMENT
10632       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10633       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10634       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10635       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10636       ss13 = scalar2(b1(1,itk),vtemp4(1))
10637       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10638 #endif
10639 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10640 !      s1=0.0d0
10641 !      s2=0.0d0
10642 !      s8=0.0d0
10643 !      s12=0.0d0
10644 !      s13=0.0d0
10645       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10646 ! Derivatives in gamma(i+2)
10647       s1d =0.0d0
10648       s8d =0.0d0
10649 #ifdef MOMENT
10650       call transpose2(AEA(1,1,1),auxmatd(1,1))
10651       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10652       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10653       call transpose2(AEAderg(1,1,2),atempd(1,1))
10654       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10655       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10656 #endif
10657       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10658       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10659       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10660 !      s1d=0.0d0
10661 !      s2d=0.0d0
10662 !      s8d=0.0d0
10663 !      s12d=0.0d0
10664 !      s13d=0.0d0
10665       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10666 ! Derivatives in gamma(i+3)
10667 #ifdef MOMENT
10668       call transpose2(AEA(1,1,1),auxmatd(1,1))
10669       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10670       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
10671       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10672 #endif
10673       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
10674       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10675       s2d = scalar2(b1(1,itk),vtemp1d(1))
10676 #ifdef MOMENT
10677       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10678       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10679 #endif
10680       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10681 #ifdef MOMENT
10682       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10683       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10684       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10685 #endif
10686 !      s1d=0.0d0
10687 !      s2d=0.0d0
10688 !      s8d=0.0d0
10689 !      s12d=0.0d0
10690 !      s13d=0.0d0
10691 #ifdef MOMENT
10692       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10693                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10694 #else
10695       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10696                     -0.5d0*ekont*(s2d+s12d)
10697 #endif
10698 ! Derivatives in gamma(i+4)
10699       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10700       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10701       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10702 #ifdef MOMENT
10703       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10704       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10705       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10706 #endif
10707 !      s1d=0.0d0
10708 !      s2d=0.0d0
10709 !      s8d=0.0d0
10710 !      s12d=0.0d0
10711 !      s13d=0.0d0
10712 #ifdef MOMENT
10713       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10714 #else
10715       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10716 #endif
10717 ! Derivatives in gamma(i+5)
10718 #ifdef MOMENT
10719       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10720       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10721       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10722 #endif
10723       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10724       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10725       s2d = scalar2(b1(1,itk),vtemp1d(1))
10726 #ifdef MOMENT
10727       call transpose2(AEA(1,1,2),atempd(1,1))
10728       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10729       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10730 #endif
10731       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10732       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10733 #ifdef MOMENT
10734       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10735       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10736       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10737 #endif
10738 !      s1d=0.0d0
10739 !      s2d=0.0d0
10740 !      s8d=0.0d0
10741 !      s12d=0.0d0
10742 !      s13d=0.0d0
10743 #ifdef MOMENT
10744       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10745                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10746 #else
10747       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10748                     -0.5d0*ekont*(s2d+s12d)
10749 #endif
10750 ! Cartesian derivatives
10751       do iii=1,2
10752         do kkk=1,5
10753           do lll=1,3
10754 #ifdef MOMENT
10755             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10756             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10757             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10758 #endif
10759             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10760             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10761                 vtemp1d(1))
10762             s2d = scalar2(b1(1,itk),vtemp1d(1))
10763 #ifdef MOMENT
10764             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10765             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10766             s8d = -(atempd(1,1)+atempd(2,2))* &
10767                  scalar2(cc(1,1,itl),vtemp2(1))
10768 #endif
10769             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10770                  auxmatd(1,1))
10771             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10772             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10773 !      s1d=0.0d0
10774 !      s2d=0.0d0
10775 !      s8d=0.0d0
10776 !      s12d=0.0d0
10777 !      s13d=0.0d0
10778 #ifdef MOMENT
10779             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10780               - 0.5d0*(s1d+s2d)
10781 #else
10782             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10783               - 0.5d0*s2d
10784 #endif
10785 #ifdef MOMENT
10786             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10787               - 0.5d0*(s8d+s12d)
10788 #else
10789             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10790               - 0.5d0*s12d
10791 #endif
10792           enddo
10793         enddo
10794       enddo
10795 #ifdef MOMENT
10796       do kkk=1,5
10797         do lll=1,3
10798           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10799             achuj_tempd(1,1))
10800           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10801           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10802           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10803           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10804           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10805             vtemp4d(1))
10806           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10807           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10808           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10809         enddo
10810       enddo
10811 #endif
10812 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10813 !d     &  16*eel_turn6_num
10814 !d      goto 1112
10815       if (j.lt.nres-1) then
10816         j1=j+1
10817         j2=j-1
10818       else
10819         j1=j-1
10820         j2=j-2
10821       endif
10822       if (l.lt.nres-1) then
10823         l1=l+1
10824         l2=l-1
10825       else
10826         l1=l-1
10827         l2=l-2
10828       endif
10829       do ll=1,3
10830 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10831 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10832 !grad        ghalf=0.5d0*ggg1(ll)
10833 !d        ghalf=0.0d0
10834         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10835         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10836         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
10837           +ekont*derx_turn(ll,2,1)
10838         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10839         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
10840           +ekont*derx_turn(ll,4,1)
10841         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10842         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10843         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10844 !grad        ghalf=0.5d0*ggg2(ll)
10845 !d        ghalf=0.0d0
10846         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
10847           +ekont*derx_turn(ll,2,2)
10848         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10849         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10850           +ekont*derx_turn(ll,4,2)
10851         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10852         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10853         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10854       enddo
10855 !d      goto 1112
10856 !grad      do m=i+1,j-1
10857 !grad        do ll=1,3
10858 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10859 !grad        enddo
10860 !grad      enddo
10861 !grad      do m=k+1,l-1
10862 !grad        do ll=1,3
10863 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10864 !grad        enddo
10865 !grad      enddo
10866 !grad1112  continue
10867 !grad      do m=i+2,j2
10868 !grad        do ll=1,3
10869 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10870 !grad        enddo
10871 !grad      enddo
10872 !grad      do m=k+2,l2
10873 !grad        do ll=1,3
10874 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10875 !grad        enddo
10876 !grad      enddo
10877 !d      do iii=1,nres-3
10878 !d        write (2,*) iii,g_corr6_loc(iii)
10879 !d      enddo
10880       eello_turn6=ekont*eel_turn6
10881 !d      write (2,*) 'ekont',ekont
10882 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
10883       return
10884       end function eello_turn6
10885 !-----------------------------------------------------------------------------
10886       subroutine MATVEC2(A1,V1,V2)
10887 !DIR$ INLINEALWAYS MATVEC2
10888 #ifndef OSF
10889 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10890 #endif
10891 !      implicit real*8 (a-h,o-z)
10892 !      include 'DIMENSIONS'
10893       real(kind=8),dimension(2) :: V1,V2
10894       real(kind=8),dimension(2,2) :: A1
10895       real(kind=8) :: vaux1,vaux2
10896 !      DO 1 I=1,2
10897 !        VI=0.0
10898 !        DO 3 K=1,2
10899 !    3     VI=VI+A1(I,K)*V1(K)
10900 !        Vaux(I)=VI
10901 !    1 CONTINUE
10902
10903       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10904       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10905
10906       v2(1)=vaux1
10907       v2(2)=vaux2
10908       end subroutine MATVEC2
10909 !-----------------------------------------------------------------------------
10910       subroutine MATMAT2(A1,A2,A3)
10911 #ifndef OSF
10912 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10913 #endif
10914 !      implicit real*8 (a-h,o-z)
10915 !      include 'DIMENSIONS'
10916       real(kind=8),dimension(2,2) :: A1,A2,A3
10917       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
10918 !      DIMENSION AI3(2,2)
10919 !        DO  J=1,2
10920 !          A3IJ=0.0
10921 !          DO K=1,2
10922 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10923 !          enddo
10924 !          A3(I,J)=A3IJ
10925 !       enddo
10926 !      enddo
10927
10928       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10929       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10930       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10931       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10932
10933       A3(1,1)=AI3_11
10934       A3(2,1)=AI3_21
10935       A3(1,2)=AI3_12
10936       A3(2,2)=AI3_22
10937       end subroutine MATMAT2
10938 !-----------------------------------------------------------------------------
10939       real(kind=8) function scalar2(u,v)
10940 !DIR$ INLINEALWAYS scalar2
10941       implicit none
10942       real(kind=8),dimension(2) :: u,v
10943       real(kind=8) :: sc
10944       integer :: i
10945       scalar2=u(1)*v(1)+u(2)*v(2)
10946       return
10947       end function scalar2
10948 !-----------------------------------------------------------------------------
10949       subroutine transpose2(a,at)
10950 !DIR$ INLINEALWAYS transpose2
10951 #ifndef OSF
10952 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
10953 #endif
10954       implicit none
10955       real(kind=8),dimension(2,2) :: a,at
10956       at(1,1)=a(1,1)
10957       at(1,2)=a(2,1)
10958       at(2,1)=a(1,2)
10959       at(2,2)=a(2,2)
10960       return
10961       end subroutine transpose2
10962 !-----------------------------------------------------------------------------
10963       subroutine transpose(n,a,at)
10964       implicit none
10965       integer :: n,i,j
10966       real(kind=8),dimension(n,n) :: a,at
10967       do i=1,n
10968         do j=1,n
10969           at(j,i)=a(i,j)
10970         enddo
10971       enddo
10972       return
10973       end subroutine transpose
10974 !-----------------------------------------------------------------------------
10975       subroutine prodmat3(a1,a2,kk,transp,prod)
10976 !DIR$ INLINEALWAYS prodmat3
10977 #ifndef OSF
10978 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
10979 #endif
10980       implicit none
10981       integer :: i,j
10982       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
10983       logical :: transp
10984 !rc      double precision auxmat(2,2),prod_(2,2)
10985
10986       if (transp) then
10987 !rc        call transpose2(kk(1,1),auxmat(1,1))
10988 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10989 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10990
10991            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
10992        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10993            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
10994        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10995            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
10996        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10997            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
10998        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10999
11000       else
11001 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11002 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11003
11004            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
11005         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11006            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
11007         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11008            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
11009         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11010            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
11011         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11012
11013       endif
11014 !      call transpose2(a2(1,1),a2t(1,1))
11015
11016 !rc      print *,transp
11017 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
11018 !rc      print *,((prod(i,j),i=1,2),j=1,2)
11019
11020       return
11021       end subroutine prodmat3
11022 !-----------------------------------------------------------------------------
11023 ! energy_p_new_barrier.F
11024 !-----------------------------------------------------------------------------
11025       subroutine sum_gradient
11026 !      implicit real*8 (a-h,o-z)
11027       use io_base, only: pdbout
11028 !      include 'DIMENSIONS'
11029 #ifndef ISNAN
11030       external proc_proc
11031 #ifdef WINPGI
11032 !MS$ATTRIBUTES C ::  proc_proc
11033 #endif
11034 #endif
11035 #ifdef MPI
11036       include 'mpif.h'
11037 #endif
11038       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
11039                    gloc_scbuf !(3,maxres)
11040
11041       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
11042 !#endif
11043 !el local variables
11044       integer :: i,j,k,ierror,ierr
11045       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
11046                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
11047                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
11048                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
11049                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
11050                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
11051                    gsccorr_max,gsccorrx_max,time00
11052
11053 !      include 'COMMON.SETUP'
11054 !      include 'COMMON.IOUNITS'
11055 !      include 'COMMON.FFIELD'
11056 !      include 'COMMON.DERIV'
11057 !      include 'COMMON.INTERACT'
11058 !      include 'COMMON.SBRIDGE'
11059 !      include 'COMMON.CHAIN'
11060 !      include 'COMMON.VAR'
11061 !      include 'COMMON.CONTROL'
11062 !      include 'COMMON.TIME1'
11063 !      include 'COMMON.MAXGRAD'
11064 !      include 'COMMON.SCCOR'
11065 #ifdef TIMING
11066       time01=MPI_Wtime()
11067 #endif
11068 !#define DEBUG
11069 #ifdef DEBUG
11070       write (iout,*) "sum_gradient gvdwc, gvdwx"
11071       do i=1,nres
11072         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11073          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
11074       enddo
11075       call flush(iout)
11076 #endif
11077 #ifdef MPI
11078         gradbufc=0.0d0
11079         gradbufx=0.0d0
11080         gradbufc_sum=0.0d0
11081         gloc_scbuf=0.0d0
11082         glocbuf=0.0d0
11083 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
11084         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
11085           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
11086 #endif
11087 !
11088 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
11089 !            in virtual-bond-vector coordinates
11090 !
11091 #ifdef DEBUG
11092 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
11093 !      do i=1,nres-1
11094 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
11095 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
11096 !      enddo
11097 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
11098 !      do i=1,nres-1
11099 !        write (iout,'(i5,3f10.5,2x,f10.5)')
11100 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
11101 !      enddo
11102 !      write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
11103 !      do i=1,nres
11104 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11105 !         i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
11106 !         (gvdwc_scpp(j,i),j=1,3)
11107 !      enddo
11108 !      write (iout,*) "gelc_long gvdwpp gel_loc_long"
11109 !      do i=1,nres
11110 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11111 !         i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
11112 !         (gelc_loc_long(j,i),j=1,3)
11113 !      enddo
11114       call flush(iout)
11115 #endif
11116 #ifdef SPLITELE
11117       do i=0,nct
11118         do j=1,3
11119           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11120                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11121                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11122                       wel_loc*gel_loc_long(j,i)+ &
11123                       wcorr*gradcorr_long(j,i)+ &
11124                       wcorr5*gradcorr5_long(j,i)+ &
11125                       wcorr6*gradcorr6_long(j,i)+ &
11126                       wturn6*gcorr6_turn_long(j,i)+ &
11127                       wstrain*ghpbc(j,i) &
11128                      +wliptran*gliptranc(j,i) &
11129                      +gradafm(j,i) &
11130                      +welec*gshieldc(j,i) &
11131                      +wcorr*gshieldc_ec(j,i) &
11132                      +wturn3*gshieldc_t3(j,i)&
11133                      +wturn4*gshieldc_t4(j,i)&
11134                      +wel_loc*gshieldc_ll(j,i)&
11135                      +wtube*gg_tube(j,i) &
11136                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11137                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11138                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11139                      wcorr_nucl*gradcorr_nucl(j,i)&
11140                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
11141                      wcatprot* gradpepcat(j,i)+ &
11142                      wcatcat*gradcatcat(j,i)+   &
11143                      wscbase*gvdwc_scbase(j,i)+ &
11144                      wpepbase*gvdwc_pepbase(j,i)+&
11145                      wscpho*gvdwc_scpho(j,i)+   &
11146                      wpeppho*gvdwc_peppho(j,i)
11147
11148
11149
11150
11151
11152         enddo
11153       enddo
11154 #else
11155       do i=0,nct
11156         do j=1,3
11157           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11158                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11159                       welec*gelc_long(j,i)+ &
11160                       wbond*gradb(j,i)+ &
11161                       wel_loc*gel_loc_long(j,i)+ &
11162                       wcorr*gradcorr_long(j,i)+ &
11163                       wcorr5*gradcorr5_long(j,i)+ &
11164                       wcorr6*gradcorr6_long(j,i)+ &
11165                       wturn6*gcorr6_turn_long(j,i)+ &
11166                       wstrain*ghpbc(j,i) &
11167                      +wliptran*gliptranc(j,i) &
11168                      +gradafm(j,i) &
11169                      +welec*gshieldc(j,i)&
11170                      +wcorr*gshieldc_ec(j,i) &
11171                      +wturn4*gshieldc_t4(j,i) &
11172                      +wel_loc*gshieldc_ll(j,i)&
11173                      +wtube*gg_tube(j,i) &
11174                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11175                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11176                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11177                      wcorr_nucl*gradcorr_nucl(j,i) &
11178                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
11179                      wcatprot* gradpepcat(j,i)+ &
11180                      wcatcat*gradcatcat(j,i)+   &
11181                      wscbase*gvdwc_scbase(j,i)+ &
11182                      wpepbase*gvdwc_pepbase(j,i)+&
11183                      wscpho*gvdwc_scpho(j,i)+&
11184                      wpeppho*gvdwc_peppho(j,i)
11185
11186
11187         enddo
11188       enddo
11189 #endif
11190 #ifdef MPI
11191       if (nfgtasks.gt.1) then
11192       time00=MPI_Wtime()
11193 #ifdef DEBUG
11194       write (iout,*) "gradbufc before allreduce"
11195       do i=1,nres
11196         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11197       enddo
11198       call flush(iout)
11199 #endif
11200       do i=0,nres
11201         do j=1,3
11202           gradbufc_sum(j,i)=gradbufc(j,i)
11203         enddo
11204       enddo
11205 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
11206 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
11207 !      time_reduce=time_reduce+MPI_Wtime()-time00
11208 #ifdef DEBUG
11209 !      write (iout,*) "gradbufc_sum after allreduce"
11210 !      do i=1,nres
11211 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
11212 !      enddo
11213 !      call flush(iout)
11214 #endif
11215 #ifdef TIMING
11216 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
11217 #endif
11218       do i=0,nres
11219         do k=1,3
11220           gradbufc(k,i)=0.0d0
11221         enddo
11222       enddo
11223 #ifdef DEBUG
11224       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
11225       write (iout,*) (i," jgrad_start",jgrad_start(i),&
11226                         " jgrad_end  ",jgrad_end(i),&
11227                         i=igrad_start,igrad_end)
11228 #endif
11229 !
11230 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
11231 ! do not parallelize this part.
11232 !
11233 !      do i=igrad_start,igrad_end
11234 !        do j=jgrad_start(i),jgrad_end(i)
11235 !          do k=1,3
11236 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
11237 !          enddo
11238 !        enddo
11239 !      enddo
11240       do j=1,3
11241         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11242       enddo
11243       do i=nres-2,-1,-1
11244         do j=1,3
11245           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11246         enddo
11247       enddo
11248 #ifdef DEBUG
11249       write (iout,*) "gradbufc after summing"
11250       do i=1,nres
11251         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11252       enddo
11253       call flush(iout)
11254 #endif
11255       else
11256 #endif
11257 !el#define DEBUG
11258 #ifdef DEBUG
11259       write (iout,*) "gradbufc"
11260       do i=1,nres
11261         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11262       enddo
11263       call flush(iout)
11264 #endif
11265 !el#undef DEBUG
11266       do i=-1,nres
11267         do j=1,3
11268           gradbufc_sum(j,i)=gradbufc(j,i)
11269           gradbufc(j,i)=0.0d0
11270         enddo
11271       enddo
11272       do j=1,3
11273         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11274       enddo
11275       do i=nres-2,-1,-1
11276         do j=1,3
11277           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11278         enddo
11279       enddo
11280 !      do i=nnt,nres-1
11281 !        do k=1,3
11282 !          gradbufc(k,i)=0.0d0
11283 !        enddo
11284 !        do j=i+1,nres
11285 !          do k=1,3
11286 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
11287 !          enddo
11288 !        enddo
11289 !      enddo
11290 !el#define DEBUG
11291 #ifdef DEBUG
11292       write (iout,*) "gradbufc after summing"
11293       do i=1,nres
11294         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11295       enddo
11296       call flush(iout)
11297 #endif
11298 !el#undef DEBUG
11299 #ifdef MPI
11300       endif
11301 #endif
11302       do k=1,3
11303         gradbufc(k,nres)=0.0d0
11304       enddo
11305 !el----------------
11306 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
11307 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
11308 !el-----------------
11309       do i=-1,nct
11310         do j=1,3
11311 #ifdef SPLITELE
11312           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11313                       wel_loc*gel_loc(j,i)+ &
11314                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11315                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11316                       wel_loc*gel_loc_long(j,i)+ &
11317                       wcorr*gradcorr_long(j,i)+ &
11318                       wcorr5*gradcorr5_long(j,i)+ &
11319                       wcorr6*gradcorr6_long(j,i)+ &
11320                       wturn6*gcorr6_turn_long(j,i))+ &
11321                       wbond*gradb(j,i)+ &
11322                       wcorr*gradcorr(j,i)+ &
11323                       wturn3*gcorr3_turn(j,i)+ &
11324                       wturn4*gcorr4_turn(j,i)+ &
11325                       wcorr5*gradcorr5(j,i)+ &
11326                       wcorr6*gradcorr6(j,i)+ &
11327                       wturn6*gcorr6_turn(j,i)+ &
11328                       wsccor*gsccorc(j,i) &
11329                      +wscloc*gscloc(j,i)  &
11330                      +wliptran*gliptranc(j,i) &
11331                      +gradafm(j,i) &
11332                      +welec*gshieldc(j,i) &
11333                      +welec*gshieldc_loc(j,i) &
11334                      +wcorr*gshieldc_ec(j,i) &
11335                      +wcorr*gshieldc_loc_ec(j,i) &
11336                      +wturn3*gshieldc_t3(j,i) &
11337                      +wturn3*gshieldc_loc_t3(j,i) &
11338                      +wturn4*gshieldc_t4(j,i) &
11339                      +wturn4*gshieldc_loc_t4(j,i) &
11340                      +wel_loc*gshieldc_ll(j,i) &
11341                      +wel_loc*gshieldc_loc_ll(j,i) &
11342                      +wtube*gg_tube(j,i) &
11343                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11344                      +wvdwpsb*gvdwpsb1(j,i))&
11345                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
11346 !                      if (i.eq.21) then
11347 !                      print *,"in sum",gradc(j,i,icg),wturn4*gcorr4_turn(j,i),&
11348 !                      wturn4*gshieldc_t4(j,i), &
11349 !                     wturn4*gshieldc_loc_t4(j,i)
11350 !                       endif
11351 !                 if ((i.le.2).and.(i.ge.1))
11352 !                       print *,gradc(j,i,icg),&
11353 !                      gradbufc(j,i),welec*gelc(j,i), &
11354 !                      wel_loc*gel_loc(j,i), &
11355 !                      wscp*gvdwc_scpp(j,i), &
11356 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
11357 !                      wel_loc*gel_loc_long(j,i), &
11358 !                      wcorr*gradcorr_long(j,i), &
11359 !                      wcorr5*gradcorr5_long(j,i), &
11360 !                      wcorr6*gradcorr6_long(j,i), &
11361 !                      wturn6*gcorr6_turn_long(j,i), &
11362 !                      wbond*gradb(j,i), &
11363 !                      wcorr*gradcorr(j,i), &
11364 !                      wturn3*gcorr3_turn(j,i), &
11365 !                      wturn4*gcorr4_turn(j,i), &
11366 !                      wcorr5*gradcorr5(j,i), &
11367 !                      wcorr6*gradcorr6(j,i), &
11368 !                      wturn6*gcorr6_turn(j,i), &
11369 !                      wsccor*gsccorc(j,i) &
11370 !                     ,wscloc*gscloc(j,i)  &
11371 !                     ,wliptran*gliptranc(j,i) &
11372 !                    ,gradafm(j,i) &
11373 !                     ,welec*gshieldc(j,i) &
11374 !                     ,welec*gshieldc_loc(j,i) &
11375 !                     ,wcorr*gshieldc_ec(j,i) &
11376 !                     ,wcorr*gshieldc_loc_ec(j,i) &
11377 !                     ,wturn3*gshieldc_t3(j,i) &
11378 !                     ,wturn3*gshieldc_loc_t3(j,i) &
11379 !                     ,wturn4*gshieldc_t4(j,i) &
11380 !                     ,wturn4*gshieldc_loc_t4(j,i) &
11381 !                     ,wel_loc*gshieldc_ll(j,i) &
11382 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
11383 !                     ,wtube*gg_tube(j,i) &
11384 !                     ,wbond_nucl*gradb_nucl(j,i) &
11385 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
11386 !                     wvdwpsb*gvdwpsb1(j,i)&
11387 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
11388 !
11389
11390 #else
11391           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11392                       wel_loc*gel_loc(j,i)+ &
11393                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11394                       welec*gelc_long(j,i)+ &
11395                       wel_loc*gel_loc_long(j,i)+ &
11396 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
11397                       wcorr5*gradcorr5_long(j,i)+ &
11398                       wcorr6*gradcorr6_long(j,i)+ &
11399                       wturn6*gcorr6_turn_long(j,i))+ &
11400                       wbond*gradb(j,i)+ &
11401                       wcorr*gradcorr(j,i)+ &
11402                       wturn3*gcorr3_turn(j,i)+ &
11403                       wturn4*gcorr4_turn(j,i)+ &
11404                       wcorr5*gradcorr5(j,i)+ &
11405                       wcorr6*gradcorr6(j,i)+ &
11406                       wturn6*gcorr6_turn(j,i)+ &
11407                       wsccor*gsccorc(j,i) &
11408                      +wscloc*gscloc(j,i) &
11409                      +gradafm(j,i) &
11410                      +wliptran*gliptranc(j,i) &
11411                      +welec*gshieldc(j,i) &
11412                      +welec*gshieldc_loc(j,i) &
11413                      +wcorr*gshieldc_ec(j,i) &
11414                      +wcorr*gshieldc_loc_ec(j,i) &
11415                      +wturn3*gshieldc_t3(j,i) &
11416                      +wturn3*gshieldc_loc_t3(j,i) &
11417                      +wturn4*gshieldc_t4(j,i) &
11418                      +wturn4*gshieldc_loc_t4(j,i) &
11419                      +wel_loc*gshieldc_ll(j,i) &
11420                      +wel_loc*gshieldc_loc_ll(j,i) &
11421                      +wtube*gg_tube(j,i) &
11422                      +wbond_nucl*gradb_nucl(j,i) &
11423                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11424                      +wvdwpsb*gvdwpsb1(j,i))&
11425                      +wsbloc*gsbloc(j,i)
11426
11427
11428
11429
11430 #endif
11431           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
11432                         wbond*gradbx(j,i)+ &
11433                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
11434                         wsccor*gsccorx(j,i) &
11435                        +wscloc*gsclocx(j,i) &
11436                        +wliptran*gliptranx(j,i) &
11437                        +welec*gshieldx(j,i)     &
11438                        +wcorr*gshieldx_ec(j,i)  &
11439                        +wturn3*gshieldx_t3(j,i) &
11440                        +wturn4*gshieldx_t4(j,i) &
11441                        +wel_loc*gshieldx_ll(j,i)&
11442                        +wtube*gg_tube_sc(j,i)   &
11443                        +wbond_nucl*gradbx_nucl(j,i) &
11444                        +wvdwsb*gvdwsbx(j,i) &
11445                        +welsb*gelsbx(j,i) &
11446                        +wcorr_nucl*gradxorr_nucl(j,i)&
11447                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
11448                        +wsbloc*gsblocx(j,i) &
11449                        +wcatprot* gradpepcatx(j,i)&
11450                        +wscbase*gvdwx_scbase(j,i) &
11451                        +wpepbase*gvdwx_pepbase(j,i)&
11452                        +wscpho*gvdwx_scpho(j,i)
11453 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
11454
11455         enddo
11456       enddo
11457 !#define DEBUG
11458 #ifdef DEBUG
11459       write (iout,*) "gloc before adding corr"
11460       do i=1,4*nres
11461         write (iout,*) i,gloc(i,icg)
11462       enddo
11463 #endif
11464       do i=1,nres-3
11465         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
11466          +wcorr5*g_corr5_loc(i) &
11467          +wcorr6*g_corr6_loc(i) &
11468          +wturn4*gel_loc_turn4(i) &
11469          +wturn3*gel_loc_turn3(i) &
11470          +wturn6*gel_loc_turn6(i) &
11471          +wel_loc*gel_loc_loc(i)
11472       enddo
11473 #ifdef DEBUG
11474       write (iout,*) "gloc after adding corr"
11475       do i=1,4*nres
11476         write (iout,*) i,gloc(i,icg)
11477       enddo
11478 #endif
11479 !#undef DEBUG
11480 #ifdef MPI
11481       if (nfgtasks.gt.1) then
11482         do j=1,3
11483           do i=0,nres
11484             gradbufc(j,i)=gradc(j,i,icg)
11485             gradbufx(j,i)=gradx(j,i,icg)
11486           enddo
11487         enddo
11488         do i=1,4*nres
11489           glocbuf(i)=gloc(i,icg)
11490         enddo
11491 !#define DEBUG
11492 #ifdef DEBUG
11493       write (iout,*) "gloc_sc before reduce"
11494       do i=1,nres
11495        do j=1,1
11496         write (iout,*) i,j,gloc_sc(j,i,icg)
11497        enddo
11498       enddo
11499 #endif
11500 !#undef DEBUG
11501         do i=0,nres
11502          do j=1,3
11503           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
11504          enddo
11505         enddo
11506         time00=MPI_Wtime()
11507         call MPI_Barrier(FG_COMM,IERR)
11508         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
11509         time00=MPI_Wtime()
11510         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
11511           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11512         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
11513           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11514         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
11515           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11516         time_reduce=time_reduce+MPI_Wtime()-time00
11517         call MPI_Reduce(gloc_scbuf(1,0),gloc_sc(1,0,icg),3*nres+3,&
11518           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11519         time_reduce=time_reduce+MPI_Wtime()-time00
11520 !#define DEBUG
11521 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
11522 #ifdef DEBUG
11523       write (iout,*) "gloc_sc after reduce"
11524       do i=0,nres
11525        do j=1,1
11526         write (iout,*) i,j,gloc_sc(j,i,icg)
11527        enddo
11528       enddo
11529 #endif
11530 !#undef DEBUG
11531 #ifdef DEBUG
11532       write (iout,*) "gloc after reduce"
11533       do i=1,4*nres
11534         write (iout,*) i,gloc(i,icg)
11535       enddo
11536 #endif
11537       endif
11538 #endif
11539       if (gnorm_check) then
11540 !
11541 ! Compute the maximum elements of the gradient
11542 !
11543       gvdwc_max=0.0d0
11544       gvdwc_scp_max=0.0d0
11545       gelc_max=0.0d0
11546       gvdwpp_max=0.0d0
11547       gradb_max=0.0d0
11548       ghpbc_max=0.0d0
11549       gradcorr_max=0.0d0
11550       gel_loc_max=0.0d0
11551       gcorr3_turn_max=0.0d0
11552       gcorr4_turn_max=0.0d0
11553       gradcorr5_max=0.0d0
11554       gradcorr6_max=0.0d0
11555       gcorr6_turn_max=0.0d0
11556       gsccorc_max=0.0d0
11557       gscloc_max=0.0d0
11558       gvdwx_max=0.0d0
11559       gradx_scp_max=0.0d0
11560       ghpbx_max=0.0d0
11561       gradxorr_max=0.0d0
11562       gsccorx_max=0.0d0
11563       gsclocx_max=0.0d0
11564       do i=1,nct
11565         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
11566         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
11567         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
11568         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
11569          gvdwc_scp_max=gvdwc_scp_norm
11570         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
11571         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
11572         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
11573         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
11574         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
11575         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
11576         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
11577         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
11578         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
11579         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
11580         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
11581         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
11582         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
11583           gcorr3_turn(1,i)))
11584         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
11585           gcorr3_turn_max=gcorr3_turn_norm
11586         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
11587           gcorr4_turn(1,i)))
11588         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
11589           gcorr4_turn_max=gcorr4_turn_norm
11590         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
11591         if (gradcorr5_norm.gt.gradcorr5_max) &
11592           gradcorr5_max=gradcorr5_norm
11593         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
11594         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
11595         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
11596           gcorr6_turn(1,i)))
11597         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
11598           gcorr6_turn_max=gcorr6_turn_norm
11599         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
11600         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
11601         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
11602         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
11603         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
11604         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
11605         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
11606         if (gradx_scp_norm.gt.gradx_scp_max) &
11607           gradx_scp_max=gradx_scp_norm
11608         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
11609         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
11610         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
11611         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
11612         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
11613         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
11614         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
11615         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
11616       enddo
11617       if (gradout) then
11618 #ifdef AIX
11619         open(istat,file=statname,position="append")
11620 #else
11621         open(istat,file=statname,access="append")
11622 #endif
11623         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
11624            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
11625            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
11626            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
11627            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
11628            gsccorx_max,gsclocx_max
11629         close(istat)
11630         if (gvdwc_max.gt.1.0d4) then
11631           write (iout,*) "gvdwc gvdwx gradb gradbx"
11632           do i=nnt,nct
11633             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
11634               gradb(j,i),gradbx(j,i),j=1,3)
11635           enddo
11636           call pdbout(0.0d0,'cipiszcze',iout)
11637           call flush(iout)
11638         endif
11639       endif
11640       endif
11641 !#define DEBUG
11642 #ifdef DEBUG
11643       write (iout,*) "gradc gradx gloc"
11644       do i=1,nres
11645         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
11646          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
11647       enddo
11648 #endif
11649 !#undef DEBUG
11650 #ifdef TIMING
11651       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
11652 #endif
11653       return
11654       end subroutine sum_gradient
11655 !-----------------------------------------------------------------------------
11656       subroutine sc_grad
11657 !      implicit real*8 (a-h,o-z)
11658       use calc_data
11659 !      include 'DIMENSIONS'
11660 !      include 'COMMON.CHAIN'
11661 !      include 'COMMON.DERIV'
11662 !      include 'COMMON.CALC'
11663 !      include 'COMMON.IOUNITS'
11664       real(kind=8), dimension(3) :: dcosom1,dcosom2
11665 !      print *,"wchodze"
11666       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11667           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11668       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11669           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11670
11671       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11672            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11673            +dCAVdOM12+ dGCLdOM12
11674 ! diagnostics only
11675 !      eom1=0.0d0
11676 !      eom2=0.0d0
11677 !      eom12=evdwij*eps1_om12
11678 ! end diagnostics
11679 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
11680 !       " sigder",sigder
11681 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
11682 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
11683 !C      print *,sss_ele_cut,'in sc_grad'
11684       do k=1,3
11685         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11686         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
11687       enddo
11688       do k=1,3
11689         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
11690 !C      print *,'gg',k,gg(k)
11691        enddo
11692 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11693 !      write (iout,*) "gg",(gg(k),k=1,3)
11694       do k=1,3
11695         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
11696                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11697                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
11698                   *sss_ele_cut
11699
11700         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
11701                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11702                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
11703                   *sss_ele_cut
11704
11705 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11706 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11707 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11708 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11709       enddo
11710 !
11711 ! Calculate the components of the gradient in DC and X
11712 !
11713 !grad      do k=i,j-1
11714 !grad        do l=1,3
11715 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
11716 !grad        enddo
11717 !grad      enddo
11718       do l=1,3
11719         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
11720         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
11721       enddo
11722       return
11723       end subroutine sc_grad
11724
11725       subroutine sc_grad_cat
11726       use calc_data
11727       real(kind=8), dimension(3) :: dcosom1,dcosom2
11728       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11729           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11730       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11731           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11732
11733       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11734            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11735            +dCAVdOM12+ dGCLdOM12
11736 ! diagnostics only
11737 !      eom1=0.0d0
11738 !      eom2=0.0d0
11739 !      eom12=evdwij*eps1_om12
11740 ! end diagnostics
11741
11742       do k=1,3
11743         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11744         dcosom2(k)=rij*(dc_norm(k,j)-om2*erij(k))
11745       enddo
11746       do k=1,3
11747         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))
11748 !C      print *,'gg',k,gg(k)
11749        enddo
11750 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11751 !      write (iout,*) "gg",(gg(k),k=1,3)
11752       do k=1,3
11753         gradpepcatx(k,i)=gradpepcatx(k,i)-gg(k) &
11754                   +(eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
11755                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11756
11757 !        gradpepcatx(k,j)=gradpepcatx(k,j)+gg(k) &
11758 !                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)) &
11759 !                  +eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv
11760
11761 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11762 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11763 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11764 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11765       enddo
11766 !
11767 ! Calculate the components of the gradient in DC and X
11768 !
11769       do l=1,3
11770         gradpepcat(l,i)=gradpepcat(l,i)-gg(l)
11771         gradpepcat(l,j)=gradpepcat(l,j)+gg(l)
11772       enddo
11773       end subroutine sc_grad_cat
11774
11775       subroutine sc_grad_cat_pep
11776       use calc_data
11777       real(kind=8), dimension(3) :: dcosom1,dcosom2
11778       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11779           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11780       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11781           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11782
11783       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11784            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11785            +dCAVdOM12+ dGCLdOM12
11786 ! diagnostics only
11787 !      eom1=0.0d0
11788 !      eom2=0.0d0
11789 !      eom12=evdwij*eps1_om12
11790 ! end diagnostics
11791
11792       do k=1,3
11793         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
11794         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
11795         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
11796         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
11797                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
11798                  *dsci_inv*2.0 &
11799                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
11800         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
11801                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
11802                  *dsci_inv*2.0 &
11803                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
11804         gradpepcat(k,j)=gradpepcat(k,j)+gg(k)
11805       enddo
11806       end subroutine sc_grad_cat_pep
11807
11808 #ifdef CRYST_THETA
11809 !-----------------------------------------------------------------------------
11810       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
11811
11812       use comm_calcthet
11813 !      implicit real*8 (a-h,o-z)
11814 !      include 'DIMENSIONS'
11815 !      include 'COMMON.LOCAL'
11816 !      include 'COMMON.IOUNITS'
11817 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
11818 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11819 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
11820       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
11821       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
11822 !el      integer :: it
11823 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
11824 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11825 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
11826 !el local variables
11827
11828       delthec=thetai-thet_pred_mean
11829       delthe0=thetai-theta0i
11830 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
11831       t3 = thetai-thet_pred_mean
11832       t6 = t3**2
11833       t9 = term1
11834       t12 = t3*sigcsq
11835       t14 = t12+t6*sigsqtc
11836       t16 = 1.0d0
11837       t21 = thetai-theta0i
11838       t23 = t21**2
11839       t26 = term2
11840       t27 = t21*t26
11841       t32 = termexp
11842       t40 = t32**2
11843       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
11844        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
11845        *(-t12*t9-ak*sig0inv*t27)
11846       return
11847       end subroutine mixder
11848 #endif
11849 !-----------------------------------------------------------------------------
11850 ! cartder.F
11851 !-----------------------------------------------------------------------------
11852       subroutine cartder
11853 !-----------------------------------------------------------------------------
11854 ! This subroutine calculates the derivatives of the consecutive virtual
11855 ! bond vectors and the SC vectors in the virtual-bond angles theta and
11856 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
11857 ! in the angles alpha and omega, describing the location of a side chain
11858 ! in its local coordinate system.
11859 !
11860 ! The derivatives are stored in the following arrays:
11861 !
11862 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
11863 ! The structure is as follows:
11864 !
11865 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
11866 ! 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)
11867 !         . . . . . . . . . . . .  . . . . . .
11868 ! 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)
11869 !                          .
11870 !                          .
11871 !                          .
11872 ! 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)
11873 !
11874 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
11875 ! The structure is same as above.
11876 !
11877 ! DCDS - the derivatives of the side chain vectors in the local spherical
11878 ! andgles alph and omega:
11879 !
11880 ! 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)
11881 ! 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)
11882 !                          .
11883 !                          .
11884 !                          .
11885 ! 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)
11886 !
11887 ! Version of March '95, based on an early version of November '91.
11888 !
11889 !**********************************************************************
11890 !      implicit real*8 (a-h,o-z)
11891 !      include 'DIMENSIONS'
11892 !      include 'COMMON.VAR'
11893 !      include 'COMMON.CHAIN'
11894 !      include 'COMMON.DERIV'
11895 !      include 'COMMON.GEO'
11896 !      include 'COMMON.LOCAL'
11897 !      include 'COMMON.INTERACT'
11898       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
11899       real(kind=8),dimension(3,3) :: dp,temp
11900 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
11901       real(kind=8),dimension(3) :: xx,xx1
11902 !el local variables
11903       integer :: i,k,l,j,m,ind,ind1,jjj
11904       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
11905                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
11906                  sint2,xp,yp,xxp,yyp,zzp,dj
11907
11908 !      common /przechowalnia/ fromto
11909       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
11910 ! get the position of the jth ijth fragment of the chain coordinate system
11911 ! in the fromto array.
11912 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11913 !
11914 !      maxdim=(nres-1)*(nres-2)/2
11915 !      allocate(dcdv(6,maxdim),dxds(6,nres))
11916 ! calculate the derivatives of transformation matrix elements in theta
11917 !
11918
11919 !el      call flush(iout) !el
11920       do i=1,nres-2
11921         rdt(1,1,i)=-rt(1,2,i)
11922         rdt(1,2,i)= rt(1,1,i)
11923         rdt(1,3,i)= 0.0d0
11924         rdt(2,1,i)=-rt(2,2,i)
11925         rdt(2,2,i)= rt(2,1,i)
11926         rdt(2,3,i)= 0.0d0
11927         rdt(3,1,i)=-rt(3,2,i)
11928         rdt(3,2,i)= rt(3,1,i)
11929         rdt(3,3,i)= 0.0d0
11930       enddo
11931 !
11932 ! derivatives in phi
11933 !
11934       do i=2,nres-2
11935         drt(1,1,i)= 0.0d0
11936         drt(1,2,i)= 0.0d0
11937         drt(1,3,i)= 0.0d0
11938         drt(2,1,i)= rt(3,1,i)
11939         drt(2,2,i)= rt(3,2,i)
11940         drt(2,3,i)= rt(3,3,i)
11941         drt(3,1,i)=-rt(2,1,i)
11942         drt(3,2,i)=-rt(2,2,i)
11943         drt(3,3,i)=-rt(2,3,i)
11944       enddo
11945 !
11946 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
11947 !
11948       do i=2,nres-2
11949         ind=indmat(i,i+1)
11950         do k=1,3
11951           do l=1,3
11952             temp(k,l)=rt(k,l,i)
11953           enddo
11954         enddo
11955         do k=1,3
11956           do l=1,3
11957             fromto(k,l,ind)=temp(k,l)
11958           enddo
11959         enddo
11960         do j=i+1,nres-2
11961           ind=indmat(i,j+1)
11962           do k=1,3
11963             do l=1,3
11964               dpkl=0.0d0
11965               do m=1,3
11966                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
11967               enddo
11968               dp(k,l)=dpkl
11969               fromto(k,l,ind)=dpkl
11970             enddo
11971           enddo
11972           do k=1,3
11973             do l=1,3
11974               temp(k,l)=dp(k,l)
11975             enddo
11976           enddo
11977         enddo
11978       enddo
11979 !
11980 ! Calculate derivatives.
11981 !
11982       ind1=0
11983       do i=1,nres-2
11984       ind1=ind1+1
11985 !
11986 ! Derivatives of DC(i+1) in theta(i+2)
11987 !
11988         do j=1,3
11989           do k=1,2
11990             dpjk=0.0D0
11991             do l=1,3
11992               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
11993             enddo
11994             dp(j,k)=dpjk
11995             prordt(j,k,i)=dp(j,k)
11996           enddo
11997           dp(j,3)=0.0D0
11998           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
11999         enddo
12000 !
12001 ! Derivatives of SC(i+1) in theta(i+2)
12002 !
12003         xx1(1)=-0.5D0*xloc(2,i+1)
12004         xx1(2)= 0.5D0*xloc(1,i+1)
12005         do j=1,3
12006           xj=0.0D0
12007           do k=1,2
12008             xj=xj+r(j,k,i)*xx1(k)
12009           enddo
12010           xx(j)=xj
12011         enddo
12012         do j=1,3
12013           rj=0.0D0
12014           do k=1,3
12015             rj=rj+prod(j,k,i)*xx(k)
12016           enddo
12017           dxdv(j,ind1)=rj
12018         enddo
12019 !
12020 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
12021 ! than the other off-diagonal derivatives.
12022 !
12023         do j=1,3
12024           dxoiij=0.0D0
12025           do k=1,3
12026             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12027           enddo
12028           dxdv(j,ind1+1)=dxoiij
12029         enddo
12030 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
12031 !
12032 ! Derivatives of DC(i+1) in phi(i+2)
12033 !
12034         do j=1,3
12035           do k=1,3
12036             dpjk=0.0
12037             do l=2,3
12038               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
12039             enddo
12040             dp(j,k)=dpjk
12041             prodrt(j,k,i)=dp(j,k)
12042           enddo
12043           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
12044         enddo
12045 !
12046 ! Derivatives of SC(i+1) in phi(i+2)
12047 !
12048         xx(1)= 0.0D0
12049         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
12050         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
12051         do j=1,3
12052           rj=0.0D0
12053           do k=2,3
12054             rj=rj+prod(j,k,i)*xx(k)
12055           enddo
12056           dxdv(j+3,ind1)=-rj
12057         enddo
12058 !
12059 ! Derivatives of SC(i+1) in phi(i+3).
12060 !
12061         do j=1,3
12062           dxoiij=0.0D0
12063           do k=1,3
12064             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12065           enddo
12066           dxdv(j+3,ind1+1)=dxoiij
12067         enddo
12068 !
12069 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
12070 ! theta(nres) and phi(i+3) thru phi(nres).
12071 !
12072         do j=i+1,nres-2
12073         ind1=ind1+1
12074         ind=indmat(i+1,j+1)
12075 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
12076           do k=1,3
12077             do l=1,3
12078               tempkl=0.0D0
12079               do m=1,2
12080                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
12081               enddo
12082               temp(k,l)=tempkl
12083             enddo
12084           enddo
12085 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
12086 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
12087 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
12088 ! Derivatives of virtual-bond vectors in theta
12089           do k=1,3
12090             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
12091           enddo
12092 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
12093 ! Derivatives of SC vectors in theta
12094           do k=1,3
12095             dxoijk=0.0D0
12096             do l=1,3
12097               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12098             enddo
12099             dxdv(k,ind1+1)=dxoijk
12100           enddo
12101 !
12102 !--- Calculate the derivatives in phi
12103 !
12104           do k=1,3
12105             do l=1,3
12106               tempkl=0.0D0
12107               do m=1,3
12108                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
12109               enddo
12110               temp(k,l)=tempkl
12111             enddo
12112           enddo
12113           do k=1,3
12114             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
12115         enddo
12116           do k=1,3
12117             dxoijk=0.0D0
12118             do l=1,3
12119               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12120             enddo
12121             dxdv(k+3,ind1+1)=dxoijk
12122           enddo
12123         enddo
12124       enddo
12125 !
12126 ! Derivatives in alpha and omega:
12127 !
12128       do i=2,nres-1
12129 !       dsci=dsc(itype(i,1))
12130         dsci=vbld(i+nres)
12131 #ifdef OSF
12132         alphi=alph(i)
12133         omegi=omeg(i)
12134         if(alphi.ne.alphi) alphi=100.0
12135         if(omegi.ne.omegi) omegi=-100.0
12136 #else
12137       alphi=alph(i)
12138       omegi=omeg(i)
12139 #endif
12140 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
12141       cosalphi=dcos(alphi)
12142       sinalphi=dsin(alphi)
12143       cosomegi=dcos(omegi)
12144       sinomegi=dsin(omegi)
12145       temp(1,1)=-dsci*sinalphi
12146       temp(2,1)= dsci*cosalphi*cosomegi
12147       temp(3,1)=-dsci*cosalphi*sinomegi
12148       temp(1,2)=0.0D0
12149       temp(2,2)=-dsci*sinalphi*sinomegi
12150       temp(3,2)=-dsci*sinalphi*cosomegi
12151       theta2=pi-0.5D0*theta(i+1)
12152       cost2=dcos(theta2)
12153       sint2=dsin(theta2)
12154       jjj=0
12155 !d      print *,((temp(l,k),l=1,3),k=1,2)
12156         do j=1,2
12157         xp=temp(1,j)
12158         yp=temp(2,j)
12159         xxp= xp*cost2+yp*sint2
12160         yyp=-xp*sint2+yp*cost2
12161         zzp=temp(3,j)
12162         xx(1)=xxp
12163         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
12164         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
12165         do k=1,3
12166           dj=0.0D0
12167           do l=1,3
12168             dj=dj+prod(k,l,i-1)*xx(l)
12169             enddo
12170           dxds(jjj+k,i)=dj
12171           enddo
12172         jjj=jjj+3
12173       enddo
12174       enddo
12175       return
12176       end subroutine cartder
12177 !-----------------------------------------------------------------------------
12178 ! checkder_p.F
12179 !-----------------------------------------------------------------------------
12180       subroutine check_cartgrad
12181 ! Check the gradient of Cartesian coordinates in internal coordinates.
12182 !      implicit real*8 (a-h,o-z)
12183 !      include 'DIMENSIONS'
12184 !      include 'COMMON.IOUNITS'
12185 !      include 'COMMON.VAR'
12186 !      include 'COMMON.CHAIN'
12187 !      include 'COMMON.GEO'
12188 !      include 'COMMON.LOCAL'
12189 !      include 'COMMON.DERIV'
12190       real(kind=8),dimension(6,nres) :: temp
12191       real(kind=8),dimension(3) :: xx,gg
12192       integer :: i,k,j,ii
12193       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
12194 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12195 !
12196 ! Check the gradient of the virtual-bond and SC vectors in the internal
12197 ! coordinates.
12198 !
12199       aincr=1.0d-6
12200       aincr2=5.0d-7
12201       call cartder
12202       write (iout,'(a)') '**************** dx/dalpha'
12203       write (iout,'(a)')
12204       do i=2,nres-1
12205       alphi=alph(i)
12206       alph(i)=alph(i)+aincr
12207       do k=1,3
12208         temp(k,i)=dc(k,nres+i)
12209         enddo
12210       call chainbuild
12211       do k=1,3
12212         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12213         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
12214         enddo
12215         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12216         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
12217         write (iout,'(a)')
12218       alph(i)=alphi
12219       call chainbuild
12220       enddo
12221       write (iout,'(a)')
12222       write (iout,'(a)') '**************** dx/domega'
12223       write (iout,'(a)')
12224       do i=2,nres-1
12225       omegi=omeg(i)
12226       omeg(i)=omeg(i)+aincr
12227       do k=1,3
12228         temp(k,i)=dc(k,nres+i)
12229         enddo
12230       call chainbuild
12231       do k=1,3
12232           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12233           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
12234                 (aincr*dabs(dxds(k+3,i))+aincr))
12235         enddo
12236         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12237             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
12238         write (iout,'(a)')
12239       omeg(i)=omegi
12240       call chainbuild
12241       enddo
12242       write (iout,'(a)')
12243       write (iout,'(a)') '**************** dx/dtheta'
12244       write (iout,'(a)')
12245       do i=3,nres
12246       theti=theta(i)
12247         theta(i)=theta(i)+aincr
12248         do j=i-1,nres-1
12249           do k=1,3
12250             temp(k,j)=dc(k,nres+j)
12251           enddo
12252         enddo
12253         call chainbuild
12254         do j=i-1,nres-1
12255         ii = indmat(i-2,j)
12256 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
12257         do k=1,3
12258           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12259           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
12260                   (aincr*dabs(dxdv(k,ii))+aincr))
12261           enddo
12262           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12263               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
12264           write(iout,'(a)')
12265         enddo
12266         write (iout,'(a)')
12267         theta(i)=theti
12268         call chainbuild
12269       enddo
12270       write (iout,'(a)') '***************** dx/dphi'
12271       write (iout,'(a)')
12272       do i=4,nres
12273         phi(i)=phi(i)+aincr
12274         do j=i-1,nres-1
12275           do k=1,3
12276             temp(k,j)=dc(k,nres+j)
12277           enddo
12278         enddo
12279         call chainbuild
12280         do j=i-1,nres-1
12281         ii = indmat(i-2,j)
12282 !         print *,'ii=',ii
12283         do k=1,3
12284           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12285             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
12286                   (aincr*dabs(dxdv(k+3,ii))+aincr))
12287           enddo
12288           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12289               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12290           write(iout,'(a)')
12291         enddo
12292         phi(i)=phi(i)-aincr
12293         call chainbuild
12294       enddo
12295       write (iout,'(a)') '****************** ddc/dtheta'
12296       do i=1,nres-2
12297         thet=theta(i+2)
12298         theta(i+2)=thet+aincr
12299         do j=i,nres
12300           do k=1,3
12301             temp(k,j)=dc(k,j)
12302           enddo
12303         enddo
12304         call chainbuild
12305         do j=i+1,nres-1
12306         ii = indmat(i,j)
12307 !         print *,'ii=',ii
12308         do k=1,3
12309           gg(k)=(dc(k,j)-temp(k,j))/aincr
12310           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
12311                  (aincr*dabs(dcdv(k,ii))+aincr))
12312           enddo
12313           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12314                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
12315         write (iout,'(a)')
12316         enddo
12317         do j=1,nres
12318           do k=1,3
12319             dc(k,j)=temp(k,j)
12320           enddo
12321         enddo
12322         theta(i+2)=thet
12323       enddo
12324       write (iout,'(a)') '******************* ddc/dphi'
12325       do i=1,nres-3
12326         phii=phi(i+3)
12327         phi(i+3)=phii+aincr
12328         do j=1,nres
12329           do k=1,3
12330             temp(k,j)=dc(k,j)
12331           enddo
12332         enddo
12333         call chainbuild
12334         do j=i+2,nres-1
12335         ii = indmat(i+1,j)
12336 !         print *,'ii=',ii
12337         do k=1,3
12338           gg(k)=(dc(k,j)-temp(k,j))/aincr
12339             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
12340                  (aincr*dabs(dcdv(k+3,ii))+aincr))
12341           enddo
12342           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12343                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12344         write (iout,'(a)')
12345         enddo
12346         do j=1,nres
12347           do k=1,3
12348             dc(k,j)=temp(k,j)
12349           enddo
12350         enddo
12351         phi(i+3)=phii
12352       enddo
12353       return
12354       end subroutine check_cartgrad
12355 !-----------------------------------------------------------------------------
12356       subroutine check_ecart
12357 ! Check the gradient of the energy in Cartesian coordinates.
12358 !     implicit real*8 (a-h,o-z)
12359 !     include 'DIMENSIONS'
12360 !     include 'COMMON.CHAIN'
12361 !     include 'COMMON.DERIV'
12362 !     include 'COMMON.IOUNITS'
12363 !     include 'COMMON.VAR'
12364 !     include 'COMMON.CONTACTS'
12365       use comm_srutu
12366 !el      integer :: icall
12367 !el      common /srutu/ icall
12368       real(kind=8),dimension(6) :: ggg
12369       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12370       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12371       real(kind=8),dimension(6,nres) :: grad_s
12372       real(kind=8),dimension(0:n_ene) :: energia,energia1
12373       integer :: uiparm(1)
12374       real(kind=8) :: urparm(1)
12375 !EL      external fdum
12376       integer :: nf,i,j,k
12377       real(kind=8) :: aincr,etot,etot1
12378       icg=1
12379       nf=0
12380       nfl=0
12381       call zerograd
12382       aincr=1.0D-5
12383       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
12384       nf=0
12385       icall=0
12386       call geom_to_var(nvar,x)
12387       call etotal(energia)
12388       etot=energia(0)
12389 !el      call enerprint(energia)
12390       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
12391       icall =1
12392       do i=1,nres
12393         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12394       enddo
12395       do i=1,nres
12396       do j=1,3
12397         grad_s(j,i)=gradc(j,i,icg)
12398         grad_s(j+3,i)=gradx(j,i,icg)
12399         enddo
12400       enddo
12401       call flush(iout)
12402       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12403       do i=1,nres
12404         do j=1,3
12405         xx(j)=c(j,i+nres)
12406         ddc(j)=dc(j,i)
12407         ddx(j)=dc(j,i+nres)
12408         enddo
12409       do j=1,3
12410         dc(j,i)=dc(j,i)+aincr
12411         do k=i+1,nres
12412           c(j,k)=c(j,k)+aincr
12413           c(j,k+nres)=c(j,k+nres)+aincr
12414           enddo
12415           call zerograd
12416           call etotal(energia1)
12417           etot1=energia1(0)
12418         ggg(j)=(etot1-etot)/aincr
12419         dc(j,i)=ddc(j)
12420         do k=i+1,nres
12421           c(j,k)=c(j,k)-aincr
12422           c(j,k+nres)=c(j,k+nres)-aincr
12423           enddo
12424         enddo
12425       do j=1,3
12426         c(j,i+nres)=c(j,i+nres)+aincr
12427         dc(j,i+nres)=dc(j,i+nres)+aincr
12428           call zerograd
12429           call etotal(energia1)
12430           etot1=energia1(0)
12431         ggg(j+3)=(etot1-etot)/aincr
12432         c(j,i+nres)=xx(j)
12433         dc(j,i+nres)=ddx(j)
12434         enddo
12435       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
12436          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
12437       enddo
12438       return
12439       end subroutine check_ecart
12440 #ifdef CARGRAD
12441 !-----------------------------------------------------------------------------
12442       subroutine check_ecartint
12443 ! Check the gradient of the energy in Cartesian coordinates.
12444       use io_base, only: intout
12445 !      implicit real*8 (a-h,o-z)
12446 !      include 'DIMENSIONS'
12447 !      include 'COMMON.CONTROL'
12448 !      include 'COMMON.CHAIN'
12449 !      include 'COMMON.DERIV'
12450 !      include 'COMMON.IOUNITS'
12451 !      include 'COMMON.VAR'
12452 !      include 'COMMON.CONTACTS'
12453 !      include 'COMMON.MD'
12454 !      include 'COMMON.LOCAL'
12455 !      include 'COMMON.SPLITELE'
12456       use comm_srutu
12457 !el      integer :: icall
12458 !el      common /srutu/ icall
12459       real(kind=8),dimension(6) :: ggg,ggg1
12460       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
12461       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12462       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
12463       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12464       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12465       real(kind=8),dimension(0:n_ene) :: energia,energia1
12466       integer :: uiparm(1)
12467       real(kind=8) :: urparm(1)
12468 !EL      external fdum
12469       integer :: i,j,k,nf
12470       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12471                    etot21,etot22
12472       r_cut=2.0d0
12473       rlambd=0.3d0
12474       icg=1
12475       nf=0
12476       nfl=0
12477       call intout
12478 !      call intcartderiv
12479 !      call checkintcartgrad
12480       call zerograd
12481       aincr=1.0D-5
12482       write(iout,*) 'Calling CHECK_ECARTINT.'
12483       nf=0
12484       icall=0
12485       call geom_to_var(nvar,x)
12486       write (iout,*) "split_ene ",split_ene
12487       call flush(iout)
12488       if (.not.split_ene) then
12489         call zerograd
12490         call etotal(energia)
12491         etot=energia(0)
12492         call cartgrad
12493         icall =1
12494         do i=1,nres
12495           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12496         enddo
12497         do j=1,3
12498           grad_s(j,0)=gcart(j,0)
12499         enddo
12500         do i=1,nres
12501           do j=1,3
12502             grad_s(j,i)=gcart(j,i)
12503             grad_s(j+3,i)=gxcart(j,i)
12504           enddo
12505         enddo
12506       else
12507 !- split gradient check
12508         call zerograd
12509         call etotal_long(energia)
12510 !el        call enerprint(energia)
12511         call cartgrad
12512         icall =1
12513         do i=1,nres
12514           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12515           (gxcart(j,i),j=1,3)
12516         enddo
12517         do j=1,3
12518           grad_s(j,0)=gcart(j,0)
12519         enddo
12520         do i=1,nres
12521           do j=1,3
12522             grad_s(j,i)=gcart(j,i)
12523             grad_s(j+3,i)=gxcart(j,i)
12524           enddo
12525         enddo
12526         call zerograd
12527         call etotal_short(energia)
12528         call enerprint(energia)
12529         call cartgrad
12530         icall =1
12531         do i=1,nres
12532           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12533           (gxcart(j,i),j=1,3)
12534         enddo
12535         do j=1,3
12536           grad_s1(j,0)=gcart(j,0)
12537         enddo
12538         do i=1,nres
12539           do j=1,3
12540             grad_s1(j,i)=gcart(j,i)
12541             grad_s1(j+3,i)=gxcart(j,i)
12542           enddo
12543         enddo
12544       endif
12545       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12546 !      do i=1,nres
12547       do i=nnt,nct
12548         do j=1,3
12549           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
12550           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
12551         ddc(j)=c(j,i)
12552         ddx(j)=c(j,i+nres)
12553           dcnorm_safe1(j)=dc_norm(j,i-1)
12554           dcnorm_safe2(j)=dc_norm(j,i)
12555           dxnorm_safe(j)=dc_norm(j,i+nres)
12556         enddo
12557       do j=1,3
12558         c(j,i)=ddc(j)+aincr
12559           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
12560           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
12561           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12562           dc(j,i)=c(j,i+1)-c(j,i)
12563           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12564           call int_from_cart1(.false.)
12565           if (.not.split_ene) then
12566            call zerograd
12567             call etotal(energia1)
12568             etot1=energia1(0)
12569             write (iout,*) "ij",i,j," etot1",etot1
12570           else
12571 !- split gradient
12572             call etotal_long(energia1)
12573             etot11=energia1(0)
12574             call etotal_short(energia1)
12575             etot12=energia1(0)
12576           endif
12577 !- end split gradient
12578 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12579         c(j,i)=ddc(j)-aincr
12580           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
12581           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
12582           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12583           dc(j,i)=c(j,i+1)-c(j,i)
12584           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12585           call int_from_cart1(.false.)
12586           if (.not.split_ene) then
12587             call zerograd
12588             call etotal(energia1)
12589             etot2=energia1(0)
12590             write (iout,*) "ij",i,j," etot2",etot2
12591           ggg(j)=(etot1-etot2)/(2*aincr)
12592           else
12593 !- split gradient
12594             call etotal_long(energia1)
12595             etot21=energia1(0)
12596           ggg(j)=(etot11-etot21)/(2*aincr)
12597             call etotal_short(energia1)
12598             etot22=energia1(0)
12599           ggg1(j)=(etot12-etot22)/(2*aincr)
12600 !- end split gradient
12601 !            write (iout,*) "etot21",etot21," etot22",etot22
12602           endif
12603 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12604         c(j,i)=ddc(j)
12605           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
12606           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
12607           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12608           dc(j,i)=c(j,i+1)-c(j,i)
12609           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12610           dc_norm(j,i-1)=dcnorm_safe1(j)
12611           dc_norm(j,i)=dcnorm_safe2(j)
12612           dc_norm(j,i+nres)=dxnorm_safe(j)
12613         enddo
12614       do j=1,3
12615         c(j,i+nres)=ddx(j)+aincr
12616           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12617           call int_from_cart1(.false.)
12618           if (.not.split_ene) then
12619             call zerograd
12620             call etotal(energia1)
12621             etot1=energia1(0)
12622           else
12623 !- split gradient
12624             call etotal_long(energia1)
12625             etot11=energia1(0)
12626             call etotal_short(energia1)
12627             etot12=energia1(0)
12628           endif
12629 !- end split gradient
12630         c(j,i+nres)=ddx(j)-aincr
12631           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12632           call int_from_cart1(.false.)
12633           if (.not.split_ene) then
12634            call zerograd
12635            call etotal(energia1)
12636             etot2=energia1(0)
12637           ggg(j+3)=(etot1-etot2)/(2*aincr)
12638           else
12639 !- split gradient
12640             call etotal_long(energia1)
12641             etot21=energia1(0)
12642           ggg(j+3)=(etot11-etot21)/(2*aincr)
12643             call etotal_short(energia1)
12644             etot22=energia1(0)
12645           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12646 !- end split gradient
12647           endif
12648 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12649         c(j,i+nres)=ddx(j)
12650           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12651           dc_norm(j,i+nres)=dxnorm_safe(j)
12652           call int_from_cart1(.false.)
12653         enddo
12654       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12655          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12656         if (split_ene) then
12657           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12658          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12659          k=1,6)
12660          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12661          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12662          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12663         endif
12664       enddo
12665       return
12666       end subroutine check_ecartint
12667 #else
12668 !-----------------------------------------------------------------------------
12669       subroutine check_ecartint
12670 ! Check the gradient of the energy in Cartesian coordinates.
12671       use io_base, only: intout
12672 !      implicit real*8 (a-h,o-z)
12673 !      include 'DIMENSIONS'
12674 !      include 'COMMON.CONTROL'
12675 !      include 'COMMON.CHAIN'
12676 !      include 'COMMON.DERIV'
12677 !      include 'COMMON.IOUNITS'
12678 !      include 'COMMON.VAR'
12679 !      include 'COMMON.CONTACTS'
12680 !      include 'COMMON.MD'
12681 !      include 'COMMON.LOCAL'
12682 !      include 'COMMON.SPLITELE'
12683       use comm_srutu
12684 !el      integer :: icall
12685 !el      common /srutu/ icall
12686       real(kind=8),dimension(6) :: ggg,ggg1
12687       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12688       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12689       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
12690       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12691       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12692       real(kind=8),dimension(0:n_ene) :: energia,energia1
12693       integer :: uiparm(1)
12694       real(kind=8) :: urparm(1)
12695 !EL      external fdum
12696       integer :: i,j,k,nf
12697       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12698                    etot21,etot22
12699       r_cut=2.0d0
12700       rlambd=0.3d0
12701       icg=1
12702       nf=0
12703       nfl=0
12704       call intout
12705 !      call intcartderiv
12706 !      call checkintcartgrad
12707       call zerograd
12708       aincr=1.0D-6
12709       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
12710       nf=0
12711       icall=0
12712       call geom_to_var(nvar,x)
12713       if (.not.split_ene) then
12714         call etotal(energia)
12715         etot=energia(0)
12716 !el        call enerprint(energia)
12717         call cartgrad
12718         icall =1
12719         do i=1,nres
12720           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12721         enddo
12722         do j=1,3
12723           grad_s(j,0)=gcart(j,0)
12724         enddo
12725         do i=1,nres
12726           do j=1,3
12727             grad_s(j,i)=gcart(j,i)
12728 !              if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12729
12730 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
12731             grad_s(j+3,i)=gxcart(j,i)
12732           enddo
12733         enddo
12734       else
12735 !- split gradient check
12736         call zerograd
12737         call etotal_long(energia)
12738 !el        call enerprint(energia)
12739         call cartgrad
12740         icall =1
12741         do i=1,nres
12742           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12743           (gxcart(j,i),j=1,3)
12744         enddo
12745         do j=1,3
12746           grad_s(j,0)=gcart(j,0)
12747         enddo
12748         do i=1,nres
12749           do j=1,3
12750             grad_s(j,i)=gcart(j,i)
12751 !            if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12752             grad_s(j+3,i)=gxcart(j,i)
12753           enddo
12754         enddo
12755         call zerograd
12756         call etotal_short(energia)
12757 !el        call enerprint(energia)
12758         call cartgrad
12759         icall =1
12760         do i=1,nres
12761           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12762           (gxcart(j,i),j=1,3)
12763         enddo
12764         do j=1,3
12765           grad_s1(j,0)=gcart(j,0)
12766         enddo
12767         do i=1,nres
12768           do j=1,3
12769             grad_s1(j,i)=gcart(j,i)
12770             grad_s1(j+3,i)=gxcart(j,i)
12771           enddo
12772         enddo
12773       endif
12774       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12775       do i=0,nres
12776         do j=1,3
12777         xx(j)=c(j,i+nres)
12778         ddc(j)=dc(j,i)
12779         ddx(j)=dc(j,i+nres)
12780           do k=1,3
12781             dcnorm_safe(k)=dc_norm(k,i)
12782             dxnorm_safe(k)=dc_norm(k,i+nres)
12783           enddo
12784         enddo
12785       do j=1,3
12786         dc(j,i)=ddc(j)+aincr
12787           call chainbuild_cart
12788 #ifdef MPI
12789 ! Broadcast the order to compute internal coordinates to the slaves.
12790 !          if (nfgtasks.gt.1)
12791 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12792 #endif
12793 !          call int_from_cart1(.false.)
12794           if (.not.split_ene) then
12795            call zerograd
12796             call etotal(energia1)
12797             etot1=energia1(0)
12798 !            call enerprint(energia1)
12799           else
12800 !- split gradient
12801             call etotal_long(energia1)
12802             etot11=energia1(0)
12803             call etotal_short(energia1)
12804             etot12=energia1(0)
12805 !            write (iout,*) "etot11",etot11," etot12",etot12
12806           endif
12807 !- end split gradient
12808 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12809         dc(j,i)=ddc(j)-aincr
12810           call chainbuild_cart
12811 !          call int_from_cart1(.false.)
12812           if (.not.split_ene) then
12813                   call zerograd
12814             call etotal(energia1)
12815             etot2=energia1(0)
12816           ggg(j)=(etot1-etot2)/(2*aincr)
12817           else
12818 !- split gradient
12819             call etotal_long(energia1)
12820             etot21=energia1(0)
12821           ggg(j)=(etot11-etot21)/(2*aincr)
12822             call etotal_short(energia1)
12823             etot22=energia1(0)
12824           ggg1(j)=(etot12-etot22)/(2*aincr)
12825 !- end split gradient
12826 !            write (iout,*) "etot21",etot21," etot22",etot22
12827           endif
12828 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12829         dc(j,i)=ddc(j)
12830           call chainbuild_cart
12831         enddo
12832       do j=1,3
12833         dc(j,i+nres)=ddx(j)+aincr
12834           call chainbuild_cart
12835 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
12836 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12837 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12838 !          write (iout,*) "dxnormnorm",dsqrt(
12839 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12840 !          write (iout,*) "dxnormnormsafe",dsqrt(
12841 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12842 !          write (iout,*)
12843           if (.not.split_ene) then
12844             call zerograd
12845             call etotal(energia1)
12846             etot1=energia1(0)
12847           else
12848 !- split gradient
12849             call etotal_long(energia1)
12850             etot11=energia1(0)
12851             call etotal_short(energia1)
12852             etot12=energia1(0)
12853           endif
12854 !- end split gradient
12855 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12856         dc(j,i+nres)=ddx(j)-aincr
12857           call chainbuild_cart
12858 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
12859 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12860 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12861 !          write (iout,*)
12862 !          write (iout,*) "dxnormnorm",dsqrt(
12863 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12864 !          write (iout,*) "dxnormnormsafe",dsqrt(
12865 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12866           if (.not.split_ene) then
12867             call zerograd
12868             call etotal(energia1)
12869             etot2=energia1(0)
12870           ggg(j+3)=(etot1-etot2)/(2*aincr)
12871           else
12872 !- split gradient
12873             call etotal_long(energia1)
12874             etot21=energia1(0)
12875           ggg(j+3)=(etot11-etot21)/(2*aincr)
12876             call etotal_short(energia1)
12877             etot22=energia1(0)
12878           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12879 !- end split gradient
12880           endif
12881 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12882         dc(j,i+nres)=ddx(j)
12883           call chainbuild_cart
12884         enddo
12885       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12886          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12887         if (split_ene) then
12888           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12889          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12890          k=1,6)
12891          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12892          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12893          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12894         endif
12895       enddo
12896       return
12897       end subroutine check_ecartint
12898 #endif
12899 !-----------------------------------------------------------------------------
12900       subroutine check_eint
12901 ! Check the gradient of energy in internal coordinates.
12902 !      implicit real*8 (a-h,o-z)
12903 !      include 'DIMENSIONS'
12904 !      include 'COMMON.CHAIN'
12905 !      include 'COMMON.DERIV'
12906 !      include 'COMMON.IOUNITS'
12907 !      include 'COMMON.VAR'
12908 !      include 'COMMON.GEO'
12909       use comm_srutu
12910 !el      integer :: icall
12911 !el      common /srutu/ icall
12912       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
12913       integer :: uiparm(1)
12914       real(kind=8) :: urparm(1)
12915       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
12916       character(len=6) :: key
12917 !EL      external fdum
12918       integer :: i,ii,nf
12919       real(kind=8) :: xi,aincr,etot,etot1,etot2
12920       call zerograd
12921       aincr=1.0D-7
12922       print '(a)','Calling CHECK_INT.'
12923       nf=0
12924       nfl=0
12925       icg=1
12926       call geom_to_var(nvar,x)
12927       call var_to_geom(nvar,x)
12928       call chainbuild
12929       icall=1
12930 !      print *,'ICG=',ICG
12931       call etotal(energia)
12932       etot = energia(0)
12933 !el      call enerprint(energia)
12934 !      print *,'ICG=',ICG
12935 #ifdef MPL
12936       if (MyID.ne.BossID) then
12937         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
12938         nf=x(nvar+1)
12939         nfl=x(nvar+2)
12940         icg=x(nvar+3)
12941       endif
12942 #endif
12943       nf=1
12944       nfl=3
12945 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
12946       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
12947 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
12948       icall=1
12949       do i=1,nvar
12950         xi=x(i)
12951         x(i)=xi-0.5D0*aincr
12952         call var_to_geom(nvar,x)
12953         call chainbuild
12954         call etotal(energia1)
12955         etot1=energia1(0)
12956         x(i)=xi+0.5D0*aincr
12957         call var_to_geom(nvar,x)
12958         call chainbuild
12959         call etotal(energia2)
12960         etot2=energia2(0)
12961         gg(i)=(etot2-etot1)/aincr
12962         write (iout,*) i,etot1,etot2
12963         x(i)=xi
12964       enddo
12965       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
12966           '     RelDiff*100% '
12967       do i=1,nvar
12968         if (i.le.nphi) then
12969           ii=i
12970           key = ' phi'
12971         else if (i.le.nphi+ntheta) then
12972           ii=i-nphi
12973           key=' theta'
12974         else if (i.le.nphi+ntheta+nside) then
12975            ii=i-(nphi+ntheta)
12976            key=' alpha'
12977         else
12978            ii=i-(nphi+ntheta+nside)
12979            key=' omega'
12980         endif
12981         write (iout,'(i3,a,i3,3(1pd16.6))') &
12982        i,key,ii,gg(i),gana(i),&
12983        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
12984       enddo
12985       return
12986       end subroutine check_eint
12987 !-----------------------------------------------------------------------------
12988 ! econstr_local.F
12989 !-----------------------------------------------------------------------------
12990       subroutine Econstr_back
12991 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
12992 !      implicit real*8 (a-h,o-z)
12993 !      include 'DIMENSIONS'
12994 !      include 'COMMON.CONTROL'
12995 !      include 'COMMON.VAR'
12996 !      include 'COMMON.MD'
12997       use MD_data
12998 !#ifndef LANG0
12999 !      include 'COMMON.LANGEVIN'
13000 !#else
13001 !      include 'COMMON.LANGEVIN.lang0'
13002 !#endif
13003 !      include 'COMMON.CHAIN'
13004 !      include 'COMMON.DERIV'
13005 !      include 'COMMON.GEO'
13006 !      include 'COMMON.LOCAL'
13007 !      include 'COMMON.INTERACT'
13008 !      include 'COMMON.IOUNITS'
13009 !      include 'COMMON.NAMES'
13010 !      include 'COMMON.TIME1'
13011       integer :: i,j,ii,k
13012       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
13013
13014       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
13015       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
13016       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
13017
13018       Uconst_back=0.0d0
13019       do i=1,nres
13020         dutheta(i)=0.0d0
13021         dugamma(i)=0.0d0
13022         do j=1,3
13023           duscdiff(j,i)=0.0d0
13024           duscdiffx(j,i)=0.0d0
13025         enddo
13026       enddo
13027       do i=1,nfrag_back
13028         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
13029 !
13030 ! Deviations from theta angles
13031 !
13032         utheta_i=0.0d0
13033         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
13034           dtheta_i=theta(j)-thetaref(j)
13035           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
13036           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
13037         enddo
13038         utheta(i)=utheta_i/(ii-1)
13039 !
13040 ! Deviations from gamma angles
13041 !
13042         ugamma_i=0.0d0
13043         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
13044           dgamma_i=pinorm(phi(j)-phiref(j))
13045 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
13046           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
13047           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
13048 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
13049         enddo
13050         ugamma(i)=ugamma_i/(ii-2)
13051 !
13052 ! Deviations from local SC geometry
13053 !
13054         uscdiff(i)=0.0d0
13055         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
13056           dxx=xxtab(j)-xxref(j)
13057           dyy=yytab(j)-yyref(j)
13058           dzz=zztab(j)-zzref(j)
13059           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
13060           do k=1,3
13061             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
13062              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
13063              (ii-1)
13064             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
13065              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
13066              (ii-1)
13067             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
13068            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
13069             /(ii-1)
13070           enddo
13071 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
13072 !     &      xxref(j),yyref(j),zzref(j)
13073         enddo
13074         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
13075 !        write (iout,*) i," uscdiff",uscdiff(i)
13076 !
13077 ! Put together deviations from local geometry
13078 !
13079         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
13080           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
13081 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
13082 !     &   " uconst_back",uconst_back
13083         utheta(i)=dsqrt(utheta(i))
13084         ugamma(i)=dsqrt(ugamma(i))
13085         uscdiff(i)=dsqrt(uscdiff(i))
13086       enddo
13087       return
13088       end subroutine Econstr_back
13089 !-----------------------------------------------------------------------------
13090 ! energy_p_new-sep_barrier.F
13091 !-----------------------------------------------------------------------------
13092       real(kind=8) function sscale(r)
13093 !      include "COMMON.SPLITELE"
13094       real(kind=8) :: r,gamm
13095       if(r.lt.r_cut-rlamb) then
13096         sscale=1.0d0
13097       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13098         gamm=(r-(r_cut-rlamb))/rlamb
13099         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13100       else
13101         sscale=0d0
13102       endif
13103       return
13104       end function sscale
13105       real(kind=8) function sscale_grad(r)
13106 !      include "COMMON.SPLITELE"
13107       real(kind=8) :: r,gamm
13108       if(r.lt.r_cut-rlamb) then
13109         sscale_grad=0.0d0
13110       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13111         gamm=(r-(r_cut-rlamb))/rlamb
13112         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
13113       else
13114         sscale_grad=0d0
13115       endif
13116       return
13117       end function sscale_grad
13118
13119 !!!!!!!!!! PBCSCALE
13120       real(kind=8) function sscale_ele(r)
13121 !      include "COMMON.SPLITELE"
13122       real(kind=8) :: r,gamm
13123       if(r.lt.r_cut_ele-rlamb_ele) then
13124         sscale_ele=1.0d0
13125       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13126         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13127         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13128       else
13129         sscale_ele=0d0
13130       endif
13131       return
13132       end function sscale_ele
13133
13134       real(kind=8)  function sscagrad_ele(r)
13135       real(kind=8) :: r,gamm
13136 !      include "COMMON.SPLITELE"
13137       if(r.lt.r_cut_ele-rlamb_ele) then
13138         sscagrad_ele=0.0d0
13139       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13140         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13141         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
13142       else
13143         sscagrad_ele=0.0d0
13144       endif
13145       return
13146       end function sscagrad_ele
13147       real(kind=8) function sscalelip(r)
13148       real(kind=8) r,gamm
13149         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
13150       return
13151       end function sscalelip
13152 !C-----------------------------------------------------------------------
13153       real(kind=8) function sscagradlip(r)
13154       real(kind=8) r,gamm
13155         sscagradlip=r*(6.0d0*r-6.0d0)
13156       return
13157       end function sscagradlip
13158
13159 !!!!!!!!!!!!!!!
13160 !-----------------------------------------------------------------------------
13161       subroutine elj_long(evdw)
13162 !
13163 ! This subroutine calculates the interaction energy of nonbonded side chains
13164 ! assuming the LJ potential of interaction.
13165 !
13166 !      implicit real*8 (a-h,o-z)
13167 !      include 'DIMENSIONS'
13168 !      include 'COMMON.GEO'
13169 !      include 'COMMON.VAR'
13170 !      include 'COMMON.LOCAL'
13171 !      include 'COMMON.CHAIN'
13172 !      include 'COMMON.DERIV'
13173 !      include 'COMMON.INTERACT'
13174 !      include 'COMMON.TORSION'
13175 !      include 'COMMON.SBRIDGE'
13176 !      include 'COMMON.NAMES'
13177 !      include 'COMMON.IOUNITS'
13178 !      include 'COMMON.CONTACTS'
13179       real(kind=8),parameter :: accur=1.0d-10
13180       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13181 !el local variables
13182       integer :: i,iint,j,k,itypi,itypi1,itypj
13183       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13184       real(kind=8) :: e1,e2,evdwij,evdw,sslipi,ssgradlipi,&
13185                       sslipj,ssgradlipj,aa,bb
13186 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13187       evdw=0.0D0
13188       do i=iatsc_s,iatsc_e
13189         itypi=itype(i,1)
13190         if (itypi.eq.ntyp1) cycle
13191         itypi1=itype(i+1,1)
13192         xi=c(1,nres+i)
13193         yi=c(2,nres+i)
13194         zi=c(3,nres+i)
13195         call to_box(xi,yi,zi)
13196         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13197 !
13198 ! Calculate SC interaction energy.
13199 !
13200         do iint=1,nint_gr(i)
13201 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13202 !d   &                  'iend=',iend(i,iint)
13203           do j=istart(i,iint),iend(i,iint)
13204             itypj=itype(j,1)
13205             if (itypj.eq.ntyp1) cycle
13206             xj=c(1,nres+j)-xi
13207             yj=c(2,nres+j)-yi
13208             zj=c(3,nres+j)-zi
13209             call to_box(xj,yj,zj)
13210             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13211             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13212              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13213             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13214              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13215             xj=boxshift(xj-xi,boxxsize)
13216             yj=boxshift(yj-yi,boxysize)
13217             zj=boxshift(zj-zi,boxzsize)
13218             rij=xj*xj+yj*yj+zj*zj
13219             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13220             if (sss.lt.1.0d0) then
13221               rrij=1.0D0/rij
13222               eps0ij=eps(itypi,itypj)
13223               fac=rrij**expon2
13224               e1=fac*fac*aa_aq(itypi,itypj)
13225               e2=fac*bb_aq(itypi,itypj)
13226               evdwij=e1+e2
13227               evdw=evdw+(1.0d0-sss)*evdwij
13228 !
13229 ! Calculate the components of the gradient in DC and X
13230 !
13231               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
13232               gg(1)=xj*fac
13233               gg(2)=yj*fac
13234               gg(3)=zj*fac
13235               do k=1,3
13236                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13237                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13238                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13239                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13240               enddo
13241             endif
13242           enddo      ! j
13243         enddo        ! iint
13244       enddo          ! i
13245       do i=1,nct
13246         do j=1,3
13247           gvdwc(j,i)=expon*gvdwc(j,i)
13248           gvdwx(j,i)=expon*gvdwx(j,i)
13249         enddo
13250       enddo
13251 !******************************************************************************
13252 !
13253 !                              N O T E !!!
13254 !
13255 ! To save time, the factor of EXPON has been extracted from ALL components
13256 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13257 ! use!
13258 !
13259 !******************************************************************************
13260       return
13261       end subroutine elj_long
13262 !-----------------------------------------------------------------------------
13263       subroutine elj_short(evdw)
13264 !
13265 ! This subroutine calculates the interaction energy of nonbonded side chains
13266 ! assuming the LJ potential of interaction.
13267 !
13268 !      implicit real*8 (a-h,o-z)
13269 !      include 'DIMENSIONS'
13270 !      include 'COMMON.GEO'
13271 !      include 'COMMON.VAR'
13272 !      include 'COMMON.LOCAL'
13273 !      include 'COMMON.CHAIN'
13274 !      include 'COMMON.DERIV'
13275 !      include 'COMMON.INTERACT'
13276 !      include 'COMMON.TORSION'
13277 !      include 'COMMON.SBRIDGE'
13278 !      include 'COMMON.NAMES'
13279 !      include 'COMMON.IOUNITS'
13280 !      include 'COMMON.CONTACTS'
13281       real(kind=8),parameter :: accur=1.0d-10
13282       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13283 !el local variables
13284       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
13285       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13286       real(kind=8) :: e1,e2,evdwij,evdw,sslipi,ssgradlipi,&
13287                       sslipj,ssgradlipj
13288 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13289       evdw=0.0D0
13290       do i=iatsc_s,iatsc_e
13291         itypi=itype(i,1)
13292         if (itypi.eq.ntyp1) cycle
13293         itypi1=itype(i+1,1)
13294         xi=c(1,nres+i)
13295         yi=c(2,nres+i)
13296         zi=c(3,nres+i)
13297         call to_box(xi,yi,zi)
13298         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13299 ! Change 12/1/95
13300         num_conti=0
13301 !
13302 ! Calculate SC interaction energy.
13303 !
13304         do iint=1,nint_gr(i)
13305 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13306 !d   &                  'iend=',iend(i,iint)
13307           do j=istart(i,iint),iend(i,iint)
13308             itypj=itype(j,1)
13309             if (itypj.eq.ntyp1) cycle
13310             xj=c(1,nres+j)-xi
13311             yj=c(2,nres+j)-yi
13312             zj=c(3,nres+j)-zi
13313 ! Change 12/1/95 to calculate four-body interactions
13314             rij=xj*xj+yj*yj+zj*zj
13315             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13316             if (sss.gt.0.0d0) then
13317               rrij=1.0D0/rij
13318               eps0ij=eps(itypi,itypj)
13319               fac=rrij**expon2
13320               e1=fac*fac*aa_aq(itypi,itypj)
13321               e2=fac*bb_aq(itypi,itypj)
13322               evdwij=e1+e2
13323               evdw=evdw+sss*evdwij
13324 !
13325 ! Calculate the components of the gradient in DC and X
13326 !
13327               fac=-rrij*(e1+evdwij)*sss
13328               gg(1)=xj*fac
13329               gg(2)=yj*fac
13330               gg(3)=zj*fac
13331               do k=1,3
13332                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13333                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13334                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13335                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13336               enddo
13337             endif
13338           enddo      ! j
13339         enddo        ! iint
13340       enddo          ! i
13341       do i=1,nct
13342         do j=1,3
13343           gvdwc(j,i)=expon*gvdwc(j,i)
13344           gvdwx(j,i)=expon*gvdwx(j,i)
13345         enddo
13346       enddo
13347 !******************************************************************************
13348 !
13349 !                              N O T E !!!
13350 !
13351 ! To save time, the factor of EXPON has been extracted from ALL components
13352 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13353 ! use!
13354 !
13355 !******************************************************************************
13356       return
13357       end subroutine elj_short
13358 !-----------------------------------------------------------------------------
13359       subroutine eljk_long(evdw)
13360 !
13361 ! This subroutine calculates the interaction energy of nonbonded side chains
13362 ! assuming the LJK potential of interaction.
13363 !
13364 !      implicit real*8 (a-h,o-z)
13365 !      include 'DIMENSIONS'
13366 !      include 'COMMON.GEO'
13367 !      include 'COMMON.VAR'
13368 !      include 'COMMON.LOCAL'
13369 !      include 'COMMON.CHAIN'
13370 !      include 'COMMON.DERIV'
13371 !      include 'COMMON.INTERACT'
13372 !      include 'COMMON.IOUNITS'
13373 !      include 'COMMON.NAMES'
13374       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13375       logical :: scheck
13376 !el local variables
13377       integer :: i,iint,j,k,itypi,itypi1,itypj
13378       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13379                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
13380 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13381       evdw=0.0D0
13382       do i=iatsc_s,iatsc_e
13383         itypi=itype(i,1)
13384         if (itypi.eq.ntyp1) cycle
13385         itypi1=itype(i+1,1)
13386         xi=c(1,nres+i)
13387         yi=c(2,nres+i)
13388         zi=c(3,nres+i)
13389           call to_box(xi,yi,zi)
13390
13391 !
13392 ! Calculate SC interaction energy.
13393 !
13394         do iint=1,nint_gr(i)
13395           do j=istart(i,iint),iend(i,iint)
13396             itypj=itype(j,1)
13397             if (itypj.eq.ntyp1) cycle
13398             xj=c(1,nres+j)-xi
13399             yj=c(2,nres+j)-yi
13400             zj=c(3,nres+j)-zi
13401           call to_box(xj,yj,zj)
13402             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13403             fac_augm=rrij**expon
13404             e_augm=augm(itypi,itypj)*fac_augm
13405             r_inv_ij=dsqrt(rrij)
13406             rij=1.0D0/r_inv_ij
13407             sss=sscale(rij/sigma(itypi,itypj))
13408             if (sss.lt.1.0d0) then
13409               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13410               fac=r_shift_inv**expon
13411               e1=fac*fac*aa_aq(itypi,itypj)
13412               e2=fac*bb_aq(itypi,itypj)
13413               evdwij=e_augm+e1+e2
13414 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13415 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13416 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13417 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13418 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13419 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13420 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13421               evdw=evdw+(1.0d0-sss)*evdwij
13422 !
13423 ! Calculate the components of the gradient in DC and X
13424 !
13425               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13426               fac=fac*(1.0d0-sss)
13427               gg(1)=xj*fac
13428               gg(2)=yj*fac
13429               gg(3)=zj*fac
13430               do k=1,3
13431                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13432                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13433                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13434                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13435               enddo
13436             endif
13437           enddo      ! j
13438         enddo        ! iint
13439       enddo          ! i
13440       do i=1,nct
13441         do j=1,3
13442           gvdwc(j,i)=expon*gvdwc(j,i)
13443           gvdwx(j,i)=expon*gvdwx(j,i)
13444         enddo
13445       enddo
13446       return
13447       end subroutine eljk_long
13448 !-----------------------------------------------------------------------------
13449       subroutine eljk_short(evdw)
13450 !
13451 ! This subroutine calculates the interaction energy of nonbonded side chains
13452 ! assuming the LJK potential of interaction.
13453 !
13454 !      implicit real*8 (a-h,o-z)
13455 !      include 'DIMENSIONS'
13456 !      include 'COMMON.GEO'
13457 !      include 'COMMON.VAR'
13458 !      include 'COMMON.LOCAL'
13459 !      include 'COMMON.CHAIN'
13460 !      include 'COMMON.DERIV'
13461 !      include 'COMMON.INTERACT'
13462 !      include 'COMMON.IOUNITS'
13463 !      include 'COMMON.NAMES'
13464       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13465       logical :: scheck
13466 !el local variables
13467       integer :: i,iint,j,k,itypi,itypi1,itypj
13468       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13469                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij,&
13470                    sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
13471 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13472       evdw=0.0D0
13473       do i=iatsc_s,iatsc_e
13474         itypi=itype(i,1)
13475         if (itypi.eq.ntyp1) cycle
13476         itypi1=itype(i+1,1)
13477         xi=c(1,nres+i)
13478         yi=c(2,nres+i)
13479         zi=c(3,nres+i)
13480         call to_box(xi,yi,zi)
13481         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13482 !
13483 ! Calculate SC interaction energy.
13484 !
13485         do iint=1,nint_gr(i)
13486           do j=istart(i,iint),iend(i,iint)
13487             itypj=itype(j,1)
13488             if (itypj.eq.ntyp1) cycle
13489             xj=c(1,nres+j)-xi
13490             yj=c(2,nres+j)-yi
13491             zj=c(3,nres+j)-zi
13492             call to_box(xj,yj,zj)
13493             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13494             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13495              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13496             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13497              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13498             xj=boxshift(xj-xi,boxxsize)
13499             yj=boxshift(yj-yi,boxysize)
13500             zj=boxshift(zj-zi,boxzsize)
13501             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13502             fac_augm=rrij**expon
13503             e_augm=augm(itypi,itypj)*fac_augm
13504             r_inv_ij=dsqrt(rrij)
13505             rij=1.0D0/r_inv_ij
13506             sss=sscale(rij/sigma(itypi,itypj))
13507             if (sss.gt.0.0d0) then
13508               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13509               fac=r_shift_inv**expon
13510               e1=fac*fac*aa_aq(itypi,itypj)
13511               e2=fac*bb_aq(itypi,itypj)
13512               evdwij=e_augm+e1+e2
13513 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13514 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13515 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13516 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13517 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13518 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13519 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13520               evdw=evdw+sss*evdwij
13521 !
13522 ! Calculate the components of the gradient in DC and X
13523 !
13524               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13525               fac=fac*sss
13526               gg(1)=xj*fac
13527               gg(2)=yj*fac
13528               gg(3)=zj*fac
13529               do k=1,3
13530                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13531                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13532                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13533                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13534               enddo
13535             endif
13536           enddo      ! j
13537         enddo        ! iint
13538       enddo          ! i
13539       do i=1,nct
13540         do j=1,3
13541           gvdwc(j,i)=expon*gvdwc(j,i)
13542           gvdwx(j,i)=expon*gvdwx(j,i)
13543         enddo
13544       enddo
13545       return
13546       end subroutine eljk_short
13547 !-----------------------------------------------------------------------------
13548        subroutine ebp_long(evdw)
13549 ! This subroutine calculates the interaction energy of nonbonded side chains
13550 ! assuming the Berne-Pechukas potential of interaction.
13551 !
13552        use calc_data
13553 !      implicit real*8 (a-h,o-z)
13554 !      include 'DIMENSIONS'
13555 !      include 'COMMON.GEO'
13556 !      include 'COMMON.VAR'
13557 !      include 'COMMON.LOCAL'
13558 !      include 'COMMON.CHAIN'
13559 !      include 'COMMON.DERIV'
13560 !      include 'COMMON.NAMES'
13561 !      include 'COMMON.INTERACT'
13562 !      include 'COMMON.IOUNITS'
13563 !      include 'COMMON.CALC'
13564        use comm_srutu
13565 !el      integer :: icall
13566 !el      common /srutu/ icall
13567 !     double precision rrsave(maxdim)
13568         logical :: lprn
13569 !el local variables
13570         integer :: iint,itypi,itypi1,itypj
13571         real(kind=8) :: rrij,xi,yi,zi,fac,sslipi,ssgradlipi,&
13572                         sslipj,ssgradlipj,aa,bb
13573         real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
13574         evdw=0.0D0
13575 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13576         evdw=0.0D0
13577 !     if (icall.eq.0) then
13578 !       lprn=.true.
13579 !     else
13580       lprn=.false.
13581 !     endif
13582 !el      ind=0
13583       do i=iatsc_s,iatsc_e
13584       itypi=itype(i,1)
13585       if (itypi.eq.ntyp1) cycle
13586       itypi1=itype(i+1,1)
13587       xi=c(1,nres+i)
13588       yi=c(2,nres+i)
13589       zi=c(3,nres+i)
13590         call to_box(xi,yi,zi)
13591         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13592       dxi=dc_norm(1,nres+i)
13593       dyi=dc_norm(2,nres+i)
13594       dzi=dc_norm(3,nres+i)
13595 !        dsci_inv=dsc_inv(itypi)
13596       dsci_inv=vbld_inv(i+nres)
13597 !
13598 ! Calculate SC interaction energy.
13599 !
13600       do iint=1,nint_gr(i)
13601       do j=istart(i,iint),iend(i,iint)
13602 !el            ind=ind+1
13603       itypj=itype(j,1)
13604       if (itypj.eq.ntyp1) cycle
13605 !            dscj_inv=dsc_inv(itypj)
13606       dscj_inv=vbld_inv(j+nres)
13607 chi1=chi(itypi,itypj)
13608 chi2=chi(itypj,itypi)
13609 chi12=chi1*chi2
13610 chip1=chip(itypi)
13611       alf1=alp(itypi)
13612       alf2=alp(itypj)
13613       alf12=0.5D0*(alf1+alf2)
13614         xj=c(1,nres+j)-xi
13615         yj=c(2,nres+j)-yi
13616         zj=c(3,nres+j)-zi
13617             call to_box(xj,yj,zj)
13618             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13619             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13620              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13621             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13622              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13623             xj=boxshift(xj-xi,boxxsize)
13624             yj=boxshift(yj-yi,boxysize)
13625             zj=boxshift(zj-zi,boxzsize)
13626         dxj=dc_norm(1,nres+j)
13627         dyj=dc_norm(2,nres+j)
13628         dzj=dc_norm(3,nres+j)
13629         rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13630         rij=dsqrt(rrij)
13631       sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13632
13633         if (sss.lt.1.0d0) then
13634
13635         ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13636         call sc_angular
13637         ! Calculate whole angle-dependent part of epsilon and contributions
13638         ! to its derivatives
13639         fac=(rrij*sigsq)**expon2
13640         e1=fac*fac*aa_aq(itypi,itypj)
13641         e2=fac*bb_aq(itypi,itypj)
13642       evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13643         eps2der=evdwij*eps3rt
13644         eps3der=evdwij*eps2rt
13645         evdwij=evdwij*eps2rt*eps3rt
13646       evdw=evdw+evdwij*(1.0d0-sss)
13647         if (lprn) then
13648         sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13649       epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13650         !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13651         !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13652         !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13653         !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13654         !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13655         !d     &          evdwij
13656         endif
13657         ! Calculate gradient components.
13658         e1=e1*eps1*eps2rt**2*eps3rt**2
13659       fac=-expon*(e1+evdwij)
13660         sigder=fac/sigsq
13661         fac=rrij*fac
13662         ! Calculate radial part of the gradient
13663         gg(1)=xj*fac
13664         gg(2)=yj*fac
13665         gg(3)=zj*fac
13666         ! Calculate the angular part of the gradient and sum add the contributions
13667         ! to the appropriate components of the Cartesian gradient.
13668       call sc_grad_scale(1.0d0-sss)
13669         endif
13670         enddo      ! j
13671         enddo        ! iint
13672         enddo          ! i
13673         !     stop
13674         return
13675         end subroutine ebp_long
13676         !-----------------------------------------------------------------------------
13677       subroutine ebp_short(evdw)
13678         !
13679         ! This subroutine calculates the interaction energy of nonbonded side chains
13680         ! assuming the Berne-Pechukas potential of interaction.
13681         !
13682         use calc_data
13683 !      implicit real*8 (a-h,o-z)
13684         !      include 'DIMENSIONS'
13685         !      include 'COMMON.GEO'
13686         !      include 'COMMON.VAR'
13687         !      include 'COMMON.LOCAL'
13688         !      include 'COMMON.CHAIN'
13689         !      include 'COMMON.DERIV'
13690         !      include 'COMMON.NAMES'
13691         !      include 'COMMON.INTERACT'
13692         !      include 'COMMON.IOUNITS'
13693         !      include 'COMMON.CALC'
13694         use comm_srutu
13695         !el      integer :: icall
13696         !el      common /srutu/ icall
13697 !     double precision rrsave(maxdim)
13698         logical :: lprn
13699         !el local variables
13700         integer :: iint,itypi,itypi1,itypj
13701         real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
13702         real(kind=8) :: sss,e1,e2,evdw,aa,bb, &
13703         sslipi,ssgradlipi,sslipj,ssgradlipj
13704         evdw=0.0D0
13705         !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13706         evdw=0.0D0
13707         !     if (icall.eq.0) then
13708         !       lprn=.true.
13709         !     else
13710         lprn=.false.
13711         !     endif
13712         !el      ind=0
13713         do i=iatsc_s,iatsc_e
13714       itypi=itype(i,1)
13715         if (itypi.eq.ntyp1) cycle
13716         itypi1=itype(i+1,1)
13717         xi=c(1,nres+i)
13718         yi=c(2,nres+i)
13719         zi=c(3,nres+i)
13720         call to_box(xi,yi,zi)
13721       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13722
13723         dxi=dc_norm(1,nres+i)
13724         dyi=dc_norm(2,nres+i)
13725         dzi=dc_norm(3,nres+i)
13726         !        dsci_inv=dsc_inv(itypi)
13727       dsci_inv=vbld_inv(i+nres)
13728         !
13729         ! Calculate SC interaction energy.
13730         !
13731         do iint=1,nint_gr(i)
13732       do j=istart(i,iint),iend(i,iint)
13733         !el            ind=ind+1
13734       itypj=itype(j,1)
13735         if (itypj.eq.ntyp1) cycle
13736         !            dscj_inv=dsc_inv(itypj)
13737         dscj_inv=vbld_inv(j+nres)
13738         chi1=chi(itypi,itypj)
13739       chi2=chi(itypj,itypi)
13740         chi12=chi1*chi2
13741         chip1=chip(itypi)
13742       chip2=chip(itypj)
13743         chip12=chip1*chip2
13744         alf1=alp(itypi)
13745         alf2=alp(itypj)
13746       alf12=0.5D0*(alf1+alf2)
13747         xj=c(1,nres+j)-xi
13748         yj=c(2,nres+j)-yi
13749         zj=c(3,nres+j)-zi
13750         call to_box(xj,yj,zj)
13751       call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13752         aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13753         +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13754         bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13755              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13756             xj=boxshift(xj-xi,boxxsize)
13757             yj=boxshift(yj-yi,boxysize)
13758             zj=boxshift(zj-zi,boxzsize)
13759             dxj=dc_norm(1,nres+j)
13760             dyj=dc_norm(2,nres+j)
13761             dzj=dc_norm(3,nres+j)
13762             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13763             rij=dsqrt(rrij)
13764             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13765
13766             if (sss.gt.0.0d0) then
13767
13768 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13769               call sc_angular
13770 ! Calculate whole angle-dependent part of epsilon and contributions
13771 ! to its derivatives
13772               fac=(rrij*sigsq)**expon2
13773               e1=fac*fac*aa_aq(itypi,itypj)
13774               e2=fac*bb_aq(itypi,itypj)
13775               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13776               eps2der=evdwij*eps3rt
13777               eps3der=evdwij*eps2rt
13778               evdwij=evdwij*eps2rt*eps3rt
13779               evdw=evdw+evdwij*sss
13780               if (lprn) then
13781               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13782               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13783 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13784 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13785 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13786 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13787 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13788 !d     &          evdwij
13789               endif
13790 ! Calculate gradient components.
13791               e1=e1*eps1*eps2rt**2*eps3rt**2
13792               fac=-expon*(e1+evdwij)
13793               sigder=fac/sigsq
13794               fac=rrij*fac
13795 ! Calculate radial part of the gradient
13796               gg(1)=xj*fac
13797               gg(2)=yj*fac
13798               gg(3)=zj*fac
13799 ! Calculate the angular part of the gradient and sum add the contributions
13800 ! to the appropriate components of the Cartesian gradient.
13801               call sc_grad_scale(sss)
13802             endif
13803           enddo      ! j
13804         enddo        ! iint
13805       enddo          ! i
13806 !     stop
13807       return
13808       end subroutine ebp_short
13809 !-----------------------------------------------------------------------------
13810       subroutine egb_long(evdw)
13811 !
13812 ! This subroutine calculates the interaction energy of nonbonded side chains
13813 ! assuming the Gay-Berne potential of interaction.
13814 !
13815       use calc_data
13816 !      implicit real*8 (a-h,o-z)
13817 !      include 'DIMENSIONS'
13818 !      include 'COMMON.GEO'
13819 !      include 'COMMON.VAR'
13820 !      include 'COMMON.LOCAL'
13821 !      include 'COMMON.CHAIN'
13822 !      include 'COMMON.DERIV'
13823 !      include 'COMMON.NAMES'
13824 !      include 'COMMON.INTERACT'
13825 !      include 'COMMON.IOUNITS'
13826 !      include 'COMMON.CALC'
13827 !      include 'COMMON.CONTROL'
13828       logical :: lprn
13829 !el local variables
13830       integer :: iint,itypi,itypi1,itypj,subchap
13831       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13832       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13833       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13834                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13835                     ssgradlipi,ssgradlipj
13836
13837
13838       evdw=0.0D0
13839 !cccc      energy_dec=.false.
13840 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13841       evdw=0.0D0
13842       lprn=.false.
13843 !     if (icall.eq.0) lprn=.false.
13844 !el      ind=0
13845       do i=iatsc_s,iatsc_e
13846         itypi=itype(i,1)
13847         if (itypi.eq.ntyp1) cycle
13848         itypi1=itype(i+1,1)
13849         xi=c(1,nres+i)
13850         yi=c(2,nres+i)
13851         zi=c(3,nres+i)
13852         call to_box(xi,yi,zi)
13853         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13854         dxi=dc_norm(1,nres+i)
13855         dyi=dc_norm(2,nres+i)
13856         dzi=dc_norm(3,nres+i)
13857 !        dsci_inv=dsc_inv(itypi)
13858         dsci_inv=vbld_inv(i+nres)
13859 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13860 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13861 !
13862 ! Calculate SC interaction energy.
13863 !
13864         do iint=1,nint_gr(i)
13865           do j=istart(i,iint),iend(i,iint)
13866             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13867 !              call dyn_ssbond_ene(i,j,evdwij)
13868 !              evdw=evdw+evdwij
13869 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13870 !                              'evdw',i,j,evdwij,' ss'
13871 !              if (energy_dec) write (iout,*) &
13872 !                              'evdw',i,j,evdwij,' ss'
13873 !             do k=j+1,iend(i,iint)
13874 !C search over all next residues
13875 !              if (dyn_ss_mask(k)) then
13876 !C check if they are cysteins
13877 !C              write(iout,*) 'k=',k
13878
13879 !c              write(iout,*) "PRZED TRI", evdwij
13880 !               evdwij_przed_tri=evdwij
13881 !              call triple_ssbond_ene(i,j,k,evdwij)
13882 !c               if(evdwij_przed_tri.ne.evdwij) then
13883 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13884 !c               endif
13885
13886 !c              write(iout,*) "PO TRI", evdwij
13887 !C call the energy function that removes the artifical triple disulfide
13888 !C bond the soubroutine is located in ssMD.F
13889 !              evdw=evdw+evdwij
13890               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13891                             'evdw',i,j,evdwij,'tss'
13892 !              endif!dyn_ss_mask(k)
13893 !             enddo! k
13894
13895             ELSE
13896 !el            ind=ind+1
13897             itypj=itype(j,1)
13898             if (itypj.eq.ntyp1) cycle
13899 !            dscj_inv=dsc_inv(itypj)
13900             dscj_inv=vbld_inv(j+nres)
13901 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13902 !     &       1.0d0/vbld(j+nres)
13903 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13904             sig0ij=sigma(itypi,itypj)
13905             chi1=chi(itypi,itypj)
13906             chi2=chi(itypj,itypi)
13907             chi12=chi1*chi2
13908             chip1=chip(itypi)
13909             chip2=chip(itypj)
13910             chip12=chip1*chip2
13911             alf1=alp(itypi)
13912             alf2=alp(itypj)
13913             alf12=0.5D0*(alf1+alf2)
13914             xj=c(1,nres+j)
13915             yj=c(2,nres+j)
13916             zj=c(3,nres+j)
13917 ! Searching for nearest neighbour
13918             call to_box(xj,yj,zj)
13919             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13920             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13921              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13922             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13923              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13924             xj=boxshift(xj-xi,boxxsize)
13925             yj=boxshift(yj-yi,boxysize)
13926             zj=boxshift(zj-zi,boxzsize)
13927             dxj=dc_norm(1,nres+j)
13928             dyj=dc_norm(2,nres+j)
13929             dzj=dc_norm(3,nres+j)
13930             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13931             rij=dsqrt(rrij)
13932             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13933             sss_ele_cut=sscale_ele(1.0d0/(rij))
13934             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
13935             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13936             if (sss_ele_cut.le.0.0) cycle
13937             if (sss.lt.1.0d0) then
13938
13939 ! Calculate angle-dependent terms of energy and contributions to their
13940 ! derivatives.
13941               call sc_angular
13942               sigsq=1.0D0/sigsq
13943               sig=sig0ij*dsqrt(sigsq)
13944               rij_shift=1.0D0/rij-sig+sig0ij
13945 ! for diagnostics; uncomment
13946 !              rij_shift=1.2*sig0ij
13947 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13948               if (rij_shift.le.0.0D0) then
13949                 evdw=1.0D20
13950 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13951 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13952 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13953                 return
13954               endif
13955               sigder=-sig*sigsq
13956 !---------------------------------------------------------------
13957               rij_shift=1.0D0/rij_shift
13958               fac=rij_shift**expon
13959               e1=fac*fac*aa
13960               e2=fac*bb
13961               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13962               eps2der=evdwij*eps3rt
13963               eps3der=evdwij*eps2rt
13964 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13965 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13966               evdwij=evdwij*eps2rt*eps3rt
13967               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
13968               if (lprn) then
13969               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13970               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13971               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13972                 restyp(itypi,1),i,restyp(itypj,1),j,&
13973                 epsi,sigm,chi1,chi2,chip1,chip2,&
13974                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13975                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13976                 evdwij
13977               endif
13978
13979               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13980                               'evdw',i,j,evdwij
13981 !              if (energy_dec) write (iout,*) &
13982 !                              'evdw',i,j,evdwij,"egb_long"
13983
13984 ! Calculate gradient components.
13985               e1=e1*eps1*eps2rt**2*eps3rt**2
13986               fac=-expon*(e1+evdwij)*rij_shift
13987               sigder=fac*sigder
13988               fac=rij*fac
13989               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13990               *rij-sss_grad/(1.0-sss)*rij  &
13991             /sigmaii(itypi,itypj))
13992 !              fac=0.0d0
13993 ! Calculate the radial part of the gradient
13994               gg(1)=xj*fac
13995               gg(2)=yj*fac
13996               gg(3)=zj*fac
13997 ! Calculate angular part of the gradient.
13998               call sc_grad_scale(1.0d0-sss)
13999             ENDIF    !mask_dyn_ss
14000             endif
14001           enddo      ! j
14002         enddo        ! iint
14003       enddo          ! i
14004 !      write (iout,*) "Number of loop steps in EGB:",ind
14005 !ccc      energy_dec=.false.
14006       return
14007       end subroutine egb_long
14008 !-----------------------------------------------------------------------------
14009       subroutine egb_short(evdw)
14010 !
14011 ! This subroutine calculates the interaction energy of nonbonded side chains
14012 ! assuming the Gay-Berne potential of interaction.
14013 !
14014       use calc_data
14015 !      implicit real*8 (a-h,o-z)
14016 !      include 'DIMENSIONS'
14017 !      include 'COMMON.GEO'
14018 !      include 'COMMON.VAR'
14019 !      include 'COMMON.LOCAL'
14020 !      include 'COMMON.CHAIN'
14021 !      include 'COMMON.DERIV'
14022 !      include 'COMMON.NAMES'
14023 !      include 'COMMON.INTERACT'
14024 !      include 'COMMON.IOUNITS'
14025 !      include 'COMMON.CALC'
14026 !      include 'COMMON.CONTROL'
14027       logical :: lprn
14028 !el local variables
14029       integer :: iint,itypi,itypi1,itypj,subchap
14030       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
14031       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
14032       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14033                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
14034                     ssgradlipi,ssgradlipj
14035       evdw=0.0D0
14036 !cccc      energy_dec=.false.
14037 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14038       evdw=0.0D0
14039       lprn=.false.
14040 !     if (icall.eq.0) lprn=.false.
14041 !el      ind=0
14042       do i=iatsc_s,iatsc_e
14043         itypi=itype(i,1)
14044         if (itypi.eq.ntyp1) cycle
14045         itypi1=itype(i+1,1)
14046         xi=c(1,nres+i)
14047         yi=c(2,nres+i)
14048         zi=c(3,nres+i)
14049         call to_box(xi,yi,zi)
14050         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14051
14052         dxi=dc_norm(1,nres+i)
14053         dyi=dc_norm(2,nres+i)
14054         dzi=dc_norm(3,nres+i)
14055 !        dsci_inv=dsc_inv(itypi)
14056         dsci_inv=vbld_inv(i+nres)
14057
14058         dxi=dc_norm(1,nres+i)
14059         dyi=dc_norm(2,nres+i)
14060         dzi=dc_norm(3,nres+i)
14061 !        dsci_inv=dsc_inv(itypi)
14062         dsci_inv=vbld_inv(i+nres)
14063         do iint=1,nint_gr(i)
14064           do j=istart(i,iint),iend(i,iint)
14065             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
14066               call dyn_ssbond_ene(i,j,evdwij)
14067               evdw=evdw+evdwij
14068               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14069                               'evdw',i,j,evdwij,' ss'
14070              do k=j+1,iend(i,iint)
14071 !C search over all next residues
14072               if (dyn_ss_mask(k)) then
14073 !C check if they are cysteins
14074 !C              write(iout,*) 'k=',k
14075
14076 !c              write(iout,*) "PRZED TRI", evdwij
14077 !               evdwij_przed_tri=evdwij
14078               call triple_ssbond_ene(i,j,k,evdwij)
14079 !c               if(evdwij_przed_tri.ne.evdwij) then
14080 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
14081 !c               endif
14082
14083 !c              write(iout,*) "PO TRI", evdwij
14084 !C call the energy function that removes the artifical triple disulfide
14085 !C bond the soubroutine is located in ssMD.F
14086               evdw=evdw+evdwij
14087               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14088                             'evdw',i,j,evdwij,'tss'
14089               endif!dyn_ss_mask(k)
14090              enddo! k
14091             ELSE
14092
14093 !          typj=itype(j,1)
14094             if (itypj.eq.ntyp1) cycle
14095 !            dscj_inv=dsc_inv(itypj)
14096             dscj_inv=vbld_inv(j+nres)
14097             dscj_inv=dsc_inv(itypj)
14098 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
14099 !     &       1.0d0/vbld(j+nres)
14100 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
14101             sig0ij=sigma(itypi,itypj)
14102             chi1=chi(itypi,itypj)
14103             chi2=chi(itypj,itypi)
14104             chi12=chi1*chi2
14105             chip1=chip(itypi)
14106             chip2=chip(itypj)
14107             chip12=chip1*chip2
14108             alf1=alp(itypi)
14109             alf2=alp(itypj)
14110             alf12=0.5D0*(alf1+alf2)
14111 !            xj=c(1,nres+j)-xi
14112 !            yj=c(2,nres+j)-yi
14113 !            zj=c(3,nres+j)-zi
14114             xj=c(1,nres+j)
14115             yj=c(2,nres+j)
14116             zj=c(3,nres+j)
14117 ! Searching for nearest neighbour
14118             call to_box(xj,yj,zj)
14119             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14120             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14121              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14122             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14123              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14124             xj=boxshift(xj-xi,boxxsize)
14125             yj=boxshift(yj-yi,boxysize)
14126             zj=boxshift(zj-zi,boxzsize)
14127             dxj=dc_norm(1,nres+j)
14128             dyj=dc_norm(2,nres+j)
14129             dzj=dc_norm(3,nres+j)
14130             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14131             rij=dsqrt(rrij)
14132             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14133             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14134             sss_ele_cut=sscale_ele(1.0d0/(rij))
14135             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
14136             if (sss_ele_cut.le.0.0) cycle
14137
14138             if (sss.gt.0.0d0) then
14139
14140 ! Calculate angle-dependent terms of energy and contributions to their
14141 ! derivatives.
14142               call sc_angular
14143               sigsq=1.0D0/sigsq
14144               sig=sig0ij*dsqrt(sigsq)
14145               rij_shift=1.0D0/rij-sig+sig0ij
14146 ! for diagnostics; uncomment
14147 !              rij_shift=1.2*sig0ij
14148 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14149               if (rij_shift.le.0.0D0) then
14150                 evdw=1.0D20
14151 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14152 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14153 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14154                 return
14155               endif
14156               sigder=-sig*sigsq
14157 !---------------------------------------------------------------
14158               rij_shift=1.0D0/rij_shift
14159               fac=rij_shift**expon
14160               e1=fac*fac*aa
14161               e2=fac*bb
14162               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14163               eps2der=evdwij*eps3rt
14164               eps3der=evdwij*eps2rt
14165 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14166 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14167               evdwij=evdwij*eps2rt*eps3rt
14168               evdw=evdw+evdwij*sss*sss_ele_cut
14169               if (lprn) then
14170               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14171               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14172               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14173                 restyp(itypi,1),i,restyp(itypj,1),j,&
14174                 epsi,sigm,chi1,chi2,chip1,chip2,&
14175                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14176                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14177                 evdwij
14178               endif
14179
14180               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14181                               'evdw',i,j,evdwij
14182 !              if (energy_dec) write (iout,*) &
14183 !                              'evdw',i,j,evdwij,"egb_short"
14184
14185 ! Calculate gradient components.
14186               e1=e1*eps1*eps2rt**2*eps3rt**2
14187               fac=-expon*(e1+evdwij)*rij_shift
14188               sigder=fac*sigder
14189               fac=rij*fac
14190               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14191             *rij+sss_grad/sss*rij  &
14192             /sigmaii(itypi,itypj))
14193
14194 !              fac=0.0d0
14195 ! Calculate the radial part of the gradient
14196               gg(1)=xj*fac
14197               gg(2)=yj*fac
14198               gg(3)=zj*fac
14199 ! Calculate angular part of the gradient.
14200               call sc_grad_scale(sss)
14201             endif
14202           ENDIF !mask_dyn_ss
14203           enddo      ! j
14204         enddo        ! iint
14205       enddo          ! i
14206 !      write (iout,*) "Number of loop steps in EGB:",ind
14207 !ccc      energy_dec=.false.
14208       return
14209       end subroutine egb_short
14210 !-----------------------------------------------------------------------------
14211       subroutine egbv_long(evdw)
14212 !
14213 ! This subroutine calculates the interaction energy of nonbonded side chains
14214 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14215 !
14216       use calc_data
14217 !      implicit real*8 (a-h,o-z)
14218 !      include 'DIMENSIONS'
14219 !      include 'COMMON.GEO'
14220 !      include 'COMMON.VAR'
14221 !      include 'COMMON.LOCAL'
14222 !      include 'COMMON.CHAIN'
14223 !      include 'COMMON.DERIV'
14224 !      include 'COMMON.NAMES'
14225 !      include 'COMMON.INTERACT'
14226 !      include 'COMMON.IOUNITS'
14227 !      include 'COMMON.CALC'
14228       use comm_srutu
14229 !el      integer :: icall
14230 !el      common /srutu/ icall
14231       logical :: lprn
14232 !el local variables
14233       integer :: iint,itypi,itypi1,itypj
14234       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij,&
14235                       sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
14236       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
14237       evdw=0.0D0
14238 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14239       evdw=0.0D0
14240       lprn=.false.
14241 !     if (icall.eq.0) lprn=.true.
14242 !el      ind=0
14243       do i=iatsc_s,iatsc_e
14244         itypi=itype(i,1)
14245         if (itypi.eq.ntyp1) cycle
14246         itypi1=itype(i+1,1)
14247         xi=c(1,nres+i)
14248         yi=c(2,nres+i)
14249         zi=c(3,nres+i)
14250         call to_box(xi,yi,zi)
14251         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14252         dxi=dc_norm(1,nres+i)
14253         dyi=dc_norm(2,nres+i)
14254         dzi=dc_norm(3,nres+i)
14255
14256 !        dsci_inv=dsc_inv(itypi)
14257         dsci_inv=vbld_inv(i+nres)
14258 !
14259 ! Calculate SC interaction energy.
14260 !
14261         do iint=1,nint_gr(i)
14262           do j=istart(i,iint),iend(i,iint)
14263 !el            ind=ind+1
14264             itypj=itype(j,1)
14265             if (itypj.eq.ntyp1) cycle
14266 !            dscj_inv=dsc_inv(itypj)
14267             dscj_inv=vbld_inv(j+nres)
14268             sig0ij=sigma(itypi,itypj)
14269             r0ij=r0(itypi,itypj)
14270             chi1=chi(itypi,itypj)
14271             chi2=chi(itypj,itypi)
14272             chi12=chi1*chi2
14273             chip1=chip(itypi)
14274             chip2=chip(itypj)
14275             chip12=chip1*chip2
14276             alf1=alp(itypi)
14277             alf2=alp(itypj)
14278             alf12=0.5D0*(alf1+alf2)
14279             xj=c(1,nres+j)-xi
14280             yj=c(2,nres+j)-yi
14281             zj=c(3,nres+j)-zi
14282             call to_box(xj,yj,zj)
14283             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14284             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14285             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14286             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14287             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14288             xj=boxshift(xj-xi,boxxsize)
14289             yj=boxshift(yj-yi,boxysize)
14290             zj=boxshift(zj-zi,boxzsize)
14291             dxj=dc_norm(1,nres+j)
14292             dyj=dc_norm(2,nres+j)
14293             dzj=dc_norm(3,nres+j)
14294             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14295             rij=dsqrt(rrij)
14296
14297             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14298
14299             if (sss.lt.1.0d0) then
14300
14301 ! Calculate angle-dependent terms of energy and contributions to their
14302 ! derivatives.
14303               call sc_angular
14304               sigsq=1.0D0/sigsq
14305               sig=sig0ij*dsqrt(sigsq)
14306               rij_shift=1.0D0/rij-sig+r0ij
14307 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14308               if (rij_shift.le.0.0D0) then
14309                 evdw=1.0D20
14310                 return
14311               endif
14312               sigder=-sig*sigsq
14313 !---------------------------------------------------------------
14314               rij_shift=1.0D0/rij_shift
14315               fac=rij_shift**expon
14316               e1=fac*fac*aa_aq(itypi,itypj)
14317               e2=fac*bb_aq(itypi,itypj)
14318               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14319               eps2der=evdwij*eps3rt
14320               eps3der=evdwij*eps2rt
14321               fac_augm=rrij**expon
14322               e_augm=augm(itypi,itypj)*fac_augm
14323               evdwij=evdwij*eps2rt*eps3rt
14324               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
14325               if (lprn) then
14326               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14327               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14328               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14329                 restyp(itypi,1),i,restyp(itypj,1),j,&
14330                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14331                 chi1,chi2,chip1,chip2,&
14332                 eps1,eps2rt**2,eps3rt**2,&
14333                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14334                 evdwij+e_augm
14335               endif
14336 ! Calculate gradient components.
14337               e1=e1*eps1*eps2rt**2*eps3rt**2
14338               fac=-expon*(e1+evdwij)*rij_shift
14339               sigder=fac*sigder
14340               fac=rij*fac-2*expon*rrij*e_augm
14341 ! Calculate the radial part of the gradient
14342               gg(1)=xj*fac
14343               gg(2)=yj*fac
14344               gg(3)=zj*fac
14345 ! Calculate angular part of the gradient.
14346               call sc_grad_scale(1.0d0-sss)
14347             endif
14348           enddo      ! j
14349         enddo        ! iint
14350       enddo          ! i
14351       end subroutine egbv_long
14352 !-----------------------------------------------------------------------------
14353       subroutine egbv_short(evdw)
14354 !
14355 ! This subroutine calculates the interaction energy of nonbonded side chains
14356 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14357 !
14358       use calc_data
14359 !      implicit real*8 (a-h,o-z)
14360 !      include 'DIMENSIONS'
14361 !      include 'COMMON.GEO'
14362 !      include 'COMMON.VAR'
14363 !      include 'COMMON.LOCAL'
14364 !      include 'COMMON.CHAIN'
14365 !      include 'COMMON.DERIV'
14366 !      include 'COMMON.NAMES'
14367 !      include 'COMMON.INTERACT'
14368 !      include 'COMMON.IOUNITS'
14369 !      include 'COMMON.CALC'
14370       use comm_srutu
14371 !el      integer :: icall
14372 !el      common /srutu/ icall
14373       logical :: lprn
14374 !el local variables
14375       integer :: iint,itypi,itypi1,itypj
14376       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift,&
14377                       sslipi,ssgradlipi, sslipj,ssgradlipj,aa,bb
14378       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
14379       evdw=0.0D0
14380 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14381       evdw=0.0D0
14382       lprn=.false.
14383 !     if (icall.eq.0) lprn=.true.
14384 !el      ind=0
14385       do i=iatsc_s,iatsc_e
14386         itypi=itype(i,1)
14387         if (itypi.eq.ntyp1) cycle
14388         itypi1=itype(i+1,1)
14389         xi=c(1,nres+i)
14390         yi=c(2,nres+i)
14391         zi=c(3,nres+i)
14392         dxi=dc_norm(1,nres+i)
14393         dyi=dc_norm(2,nres+i)
14394         dzi=dc_norm(3,nres+i)
14395         call to_box(xi,yi,zi)
14396         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14397 !        dsci_inv=dsc_inv(itypi)
14398         dsci_inv=vbld_inv(i+nres)
14399 !
14400 ! Calculate SC interaction energy.
14401 !
14402         do iint=1,nint_gr(i)
14403           do j=istart(i,iint),iend(i,iint)
14404 !el            ind=ind+1
14405             itypj=itype(j,1)
14406             if (itypj.eq.ntyp1) cycle
14407 !            dscj_inv=dsc_inv(itypj)
14408             dscj_inv=vbld_inv(j+nres)
14409             sig0ij=sigma(itypi,itypj)
14410             r0ij=r0(itypi,itypj)
14411             chi1=chi(itypi,itypj)
14412             chi2=chi(itypj,itypi)
14413             chi12=chi1*chi2
14414             chip1=chip(itypi)
14415             chip2=chip(itypj)
14416             chip12=chip1*chip2
14417             alf1=alp(itypi)
14418             alf2=alp(itypj)
14419             alf12=0.5D0*(alf1+alf2)
14420             xj=c(1,nres+j)-xi
14421             yj=c(2,nres+j)-yi
14422             zj=c(3,nres+j)-zi
14423             call to_box(xj,yj,zj)
14424             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14425             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14426             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14427             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14428             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14429             xj=boxshift(xj-xi,boxxsize)
14430             yj=boxshift(yj-yi,boxysize)
14431             zj=boxshift(zj-zi,boxzsize)
14432             dxj=dc_norm(1,nres+j)
14433             dyj=dc_norm(2,nres+j)
14434             dzj=dc_norm(3,nres+j)
14435             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14436             rij=dsqrt(rrij)
14437
14438             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14439
14440             if (sss.gt.0.0d0) then
14441
14442 ! Calculate angle-dependent terms of energy and contributions to their
14443 ! derivatives.
14444               call sc_angular
14445               sigsq=1.0D0/sigsq
14446               sig=sig0ij*dsqrt(sigsq)
14447               rij_shift=1.0D0/rij-sig+r0ij
14448 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14449               if (rij_shift.le.0.0D0) then
14450                 evdw=1.0D20
14451                 return
14452               endif
14453               sigder=-sig*sigsq
14454 !---------------------------------------------------------------
14455               rij_shift=1.0D0/rij_shift
14456               fac=rij_shift**expon
14457               e1=fac*fac*aa_aq(itypi,itypj)
14458               e2=fac*bb_aq(itypi,itypj)
14459               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14460               eps2der=evdwij*eps3rt
14461               eps3der=evdwij*eps2rt
14462               fac_augm=rrij**expon
14463               e_augm=augm(itypi,itypj)*fac_augm
14464               evdwij=evdwij*eps2rt*eps3rt
14465               evdw=evdw+(evdwij+e_augm)*sss
14466               if (lprn) then
14467               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14468               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14469               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14470                 restyp(itypi,1),i,restyp(itypj,1),j,&
14471                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14472                 chi1,chi2,chip1,chip2,&
14473                 eps1,eps2rt**2,eps3rt**2,&
14474                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14475                 evdwij+e_augm
14476               endif
14477 ! Calculate gradient components.
14478               e1=e1*eps1*eps2rt**2*eps3rt**2
14479               fac=-expon*(e1+evdwij)*rij_shift
14480               sigder=fac*sigder
14481               fac=rij*fac-2*expon*rrij*e_augm
14482 ! Calculate the radial part of the gradient
14483               gg(1)=xj*fac
14484               gg(2)=yj*fac
14485               gg(3)=zj*fac
14486 ! Calculate angular part of the gradient.
14487               call sc_grad_scale(sss)
14488             endif
14489           enddo      ! j
14490         enddo        ! iint
14491       enddo          ! i
14492       end subroutine egbv_short
14493 !-----------------------------------------------------------------------------
14494       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
14495 !
14496 ! This subroutine calculates the average interaction energy and its gradient
14497 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
14498 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
14499 ! The potential depends both on the distance of peptide-group centers and on
14500 ! the orientation of the CA-CA virtual bonds.
14501 !
14502 !      implicit real*8 (a-h,o-z)
14503
14504       use comm_locel
14505 #ifdef MPI
14506       include 'mpif.h'
14507 #endif
14508 !      include 'DIMENSIONS'
14509 !      include 'COMMON.CONTROL'
14510 !      include 'COMMON.SETUP'
14511 !      include 'COMMON.IOUNITS'
14512 !      include 'COMMON.GEO'
14513 !      include 'COMMON.VAR'
14514 !      include 'COMMON.LOCAL'
14515 !      include 'COMMON.CHAIN'
14516 !      include 'COMMON.DERIV'
14517 !      include 'COMMON.INTERACT'
14518 !      include 'COMMON.CONTACTS'
14519 !      include 'COMMON.TORSION'
14520 !      include 'COMMON.VECTORS'
14521 !      include 'COMMON.FFIELD'
14522 !      include 'COMMON.TIME1'
14523       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
14524       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
14525       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14526 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14527       real(kind=8),dimension(4) :: muij
14528 !el      integer :: num_conti,j1,j2
14529 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14530 !el                   dz_normi,xmedi,ymedi,zmedi
14531 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14532 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14533 !el          num_conti,j1,j2
14534 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14535 #ifdef MOMENT
14536       real(kind=8) :: scal_el=1.0d0
14537 #else
14538       real(kind=8) :: scal_el=0.5d0
14539 #endif
14540 ! 12/13/98
14541 ! 13-go grudnia roku pamietnego...
14542       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14543                                              0.0d0,1.0d0,0.0d0,&
14544                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14545 !el local variables
14546       integer :: i,j,k
14547       real(kind=8) :: fac
14548       real(kind=8) :: dxj,dyj,dzj
14549       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
14550
14551 !      allocate(num_cont_hb(nres)) !(maxres)
14552 !d      write(iout,*) 'In EELEC'
14553 !d      do i=1,nloctyp
14554 !d        write(iout,*) 'Type',i
14555 !d        write(iout,*) 'B1',B1(:,i)
14556 !d        write(iout,*) 'B2',B2(:,i)
14557 !d        write(iout,*) 'CC',CC(:,:,i)
14558 !d        write(iout,*) 'DD',DD(:,:,i)
14559 !d        write(iout,*) 'EE',EE(:,:,i)
14560 !d      enddo
14561 !d      call check_vecgrad
14562 !d      stop
14563       if (icheckgrad.eq.1) then
14564         do i=1,nres-1
14565           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
14566           do k=1,3
14567             dc_norm(k,i)=dc(k,i)*fac
14568           enddo
14569 !          write (iout,*) 'i',i,' fac',fac
14570         enddo
14571       endif
14572       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14573           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
14574           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
14575 !        call vec_and_deriv
14576 #ifdef TIMING
14577         time01=MPI_Wtime()
14578 #endif
14579 !        print *, "before set matrices"
14580         call set_matrices
14581 !        print *,"after set martices"
14582 #ifdef TIMING
14583         time_mat=time_mat+MPI_Wtime()-time01
14584 #endif
14585       endif
14586 !d      do i=1,nres-1
14587 !d        write (iout,*) 'i=',i
14588 !d        do k=1,3
14589 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
14590 !d        enddo
14591 !d        do k=1,3
14592 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
14593 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
14594 !d        enddo
14595 !d      enddo
14596       t_eelecij=0.0d0
14597       ees=0.0D0
14598       evdw1=0.0D0
14599       eel_loc=0.0d0
14600       eello_turn3=0.0d0
14601       eello_turn4=0.0d0
14602 !el      ind=0
14603       do i=1,nres
14604         num_cont_hb(i)=0
14605       enddo
14606 !d      print '(a)','Enter EELEC'
14607 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
14608 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14609 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14610       do i=1,nres
14611         gel_loc_loc(i)=0.0d0
14612         gcorr_loc(i)=0.0d0
14613       enddo
14614 !
14615 !
14616 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
14617 !
14618 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
14619 !
14620       do i=iturn3_start,iturn3_end
14621         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
14622         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
14623         dxi=dc(1,i)
14624         dyi=dc(2,i)
14625         dzi=dc(3,i)
14626         dx_normi=dc_norm(1,i)
14627         dy_normi=dc_norm(2,i)
14628         dz_normi=dc_norm(3,i)
14629         xmedi=c(1,i)+0.5d0*dxi
14630         ymedi=c(2,i)+0.5d0*dyi
14631         zmedi=c(3,i)+0.5d0*dzi
14632         call to_box(xmedi,ymedi,zmedi)
14633         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
14634         num_conti=0
14635         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
14636         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
14637         num_cont_hb(i)=num_conti
14638       enddo
14639       do i=iturn4_start,iturn4_end
14640         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
14641           .or. itype(i+3,1).eq.ntyp1 &
14642           .or. itype(i+4,1).eq.ntyp1) cycle
14643         dxi=dc(1,i)
14644         dyi=dc(2,i)
14645         dzi=dc(3,i)
14646         dx_normi=dc_norm(1,i)
14647         dy_normi=dc_norm(2,i)
14648         dz_normi=dc_norm(3,i)
14649         xmedi=c(1,i)+0.5d0*dxi
14650         ymedi=c(2,i)+0.5d0*dyi
14651         zmedi=c(3,i)+0.5d0*dzi
14652
14653         call to_box(xmedi,ymedi,zmedi)
14654         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
14655
14656         num_conti=num_cont_hb(i)
14657         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
14658         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
14659           call eturn4(i,eello_turn4)
14660         num_cont_hb(i)=num_conti
14661       enddo   ! i
14662 !
14663 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
14664 !
14665       do i=iatel_s,iatel_e
14666         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14667         dxi=dc(1,i)
14668         dyi=dc(2,i)
14669         dzi=dc(3,i)
14670         dx_normi=dc_norm(1,i)
14671         dy_normi=dc_norm(2,i)
14672         dz_normi=dc_norm(3,i)
14673         xmedi=c(1,i)+0.5d0*dxi
14674         ymedi=c(2,i)+0.5d0*dyi
14675         zmedi=c(3,i)+0.5d0*dzi
14676         call to_box(xmedi,ymedi,zmedi)
14677         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
14678 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14679         num_conti=num_cont_hb(i)
14680         do j=ielstart(i),ielend(i)
14681           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14682           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14683         enddo ! j
14684         num_cont_hb(i)=num_conti
14685       enddo   ! i
14686 !      write (iout,*) "Number of loop steps in EELEC:",ind
14687 !d      do i=1,nres
14688 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14689 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14690 !d      enddo
14691 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14692 !cc      eel_loc=eel_loc+eello_turn3
14693 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14694       return
14695       end subroutine eelec_scale
14696 !-----------------------------------------------------------------------------
14697       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14698 !      implicit real*8 (a-h,o-z)
14699
14700       use comm_locel
14701 !      include 'DIMENSIONS'
14702 #ifdef MPI
14703       include "mpif.h"
14704 #endif
14705 !      include 'COMMON.CONTROL'
14706 !      include 'COMMON.IOUNITS'
14707 !      include 'COMMON.GEO'
14708 !      include 'COMMON.VAR'
14709 !      include 'COMMON.LOCAL'
14710 !      include 'COMMON.CHAIN'
14711 !      include 'COMMON.DERIV'
14712 !      include 'COMMON.INTERACT'
14713 !      include 'COMMON.CONTACTS'
14714 !      include 'COMMON.TORSION'
14715 !      include 'COMMON.VECTORS'
14716 !      include 'COMMON.FFIELD'
14717 !      include 'COMMON.TIME1'
14718       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14719       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14720       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14721 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14722       real(kind=8),dimension(4) :: muij
14723       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14724                     dist_temp, dist_init,sss_grad
14725       integer xshift,yshift,zshift
14726
14727 !el      integer :: num_conti,j1,j2
14728 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14729 !el                   dz_normi,xmedi,ymedi,zmedi
14730 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14731 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14732 !el          num_conti,j1,j2
14733 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14734 #ifdef MOMENT
14735       real(kind=8) :: scal_el=1.0d0
14736 #else
14737       real(kind=8) :: scal_el=0.5d0
14738 #endif
14739 ! 12/13/98
14740 ! 13-go grudnia roku pamietnego...
14741       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14742                                              0.0d0,1.0d0,0.0d0,&
14743                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14744 !el local variables
14745       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
14746       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
14747       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
14748       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
14749       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
14750       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
14751       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
14752                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
14753                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
14754                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
14755                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
14756                   ecosam,ecosbm,ecosgm,ghalf,time00,faclipij,faclipij2
14757 !      integer :: maxconts
14758 !      maxconts = nres/4
14759 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14760 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14761 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14762 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14763 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14764 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14765 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14766 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14767 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
14768 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
14769 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
14770 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
14771 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
14772
14773 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
14774 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
14775
14776 #ifdef MPI
14777           time00=MPI_Wtime()
14778 #endif
14779 !d      write (iout,*) "eelecij",i,j
14780 !el          ind=ind+1
14781           iteli=itel(i)
14782           itelj=itel(j)
14783           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14784           aaa=app(iteli,itelj)
14785           bbb=bpp(iteli,itelj)
14786           ael6i=ael6(iteli,itelj)
14787           ael3i=ael3(iteli,itelj)
14788           dxj=dc(1,j)
14789           dyj=dc(2,j)
14790           dzj=dc(3,j)
14791           dx_normj=dc_norm(1,j)
14792           dy_normj=dc_norm(2,j)
14793           dz_normj=dc_norm(3,j)
14794 !          xj=c(1,j)+0.5D0*dxj-xmedi
14795 !          yj=c(2,j)+0.5D0*dyj-ymedi
14796 !          zj=c(3,j)+0.5D0*dzj-zmedi
14797           xj=c(1,j)+0.5D0*dxj
14798           yj=c(2,j)+0.5D0*dyj
14799           zj=c(3,j)+0.5D0*dzj
14800           call to_box(xj,yj,zj)
14801           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14802           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
14803           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
14804           xj=boxshift(xj-xmedi,boxxsize)
14805           yj=boxshift(yj-ymedi,boxysize)
14806           zj=boxshift(zj-zmedi,boxzsize)
14807           rij=xj*xj+yj*yj+zj*zj
14808           rrmij=1.0D0/rij
14809           rij=dsqrt(rij)
14810           rmij=1.0D0/rij
14811 ! For extracting the short-range part of Evdwpp
14812           sss=sscale(rij/rpp(iteli,itelj))
14813             sss_ele_cut=sscale_ele(rij)
14814             sss_ele_grad=sscagrad_ele(rij)
14815             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14816 !             sss_ele_cut=1.0d0
14817 !             sss_ele_grad=0.0d0
14818             if (sss_ele_cut.le.0.0) go to 128
14819
14820           r3ij=rrmij*rmij
14821           r6ij=r3ij*r3ij
14822           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
14823           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
14824           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
14825           fac=cosa-3.0D0*cosb*cosg
14826           ev1=aaa*r6ij*r6ij
14827 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14828           if (j.eq.i+2) ev1=scal_el*ev1
14829           ev2=bbb*r6ij
14830           fac3=ael6i*r6ij
14831           fac4=ael3i*r3ij
14832           evdwij=ev1+ev2
14833           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
14834           el2=fac4*fac
14835           eesij=el1+el2
14836 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
14837           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
14838           ees=ees+eesij*sss_ele_cut
14839           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
14840 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
14841 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
14842 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
14843 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
14844
14845           if (energy_dec) then
14846               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14847               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
14848           endif
14849
14850 !
14851 ! Calculate contributions to the Cartesian gradient.
14852 !
14853 #ifdef SPLITELE
14854           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14855           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
14856           fac1=fac
14857           erij(1)=xj*rmij
14858           erij(2)=yj*rmij
14859           erij(3)=zj*rmij
14860 !
14861 ! Radial derivatives. First process both termini of the fragment (i,j)
14862 !
14863           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
14864           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
14865           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
14866 !          do k=1,3
14867 !            ghalf=0.5D0*ggg(k)
14868 !            gelc(k,i)=gelc(k,i)+ghalf
14869 !            gelc(k,j)=gelc(k,j)+ghalf
14870 !          enddo
14871 ! 9/28/08 AL Gradient compotents will be summed only at the end
14872           do k=1,3
14873             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14874             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14875           enddo
14876 !
14877 ! Loop over residues i+1 thru j-1.
14878 !
14879 !grad          do k=i+1,j-1
14880 !grad            do l=1,3
14881 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14882 !grad            enddo
14883 !grad          enddo
14884           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
14885           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14886           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
14887           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14888           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
14889           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14890 !          do k=1,3
14891 !            ghalf=0.5D0*ggg(k)
14892 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
14893 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
14894 !          enddo
14895 ! 9/28/08 AL Gradient compotents will be summed only at the end
14896           do k=1,3
14897             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14898             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14899           enddo
14900 !
14901 ! Loop over residues i+1 thru j-1.
14902 !
14903 !grad          do k=i+1,j-1
14904 !grad            do l=1,3
14905 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
14906 !grad            enddo
14907 !grad          enddo
14908 #else
14909           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14910           facel=(el1+eesij)*sss_ele_cut
14911           fac1=fac
14912           fac=-3*rrmij*(facvdw+facvdw+facel)
14913           erij(1)=xj*rmij
14914           erij(2)=yj*rmij
14915           erij(3)=zj*rmij
14916 !
14917 ! Radial derivatives. First process both termini of the fragment (i,j)
14918 !
14919           ggg(1)=fac*xj
14920           ggg(2)=fac*yj
14921           ggg(3)=fac*zj
14922 !          do k=1,3
14923 !            ghalf=0.5D0*ggg(k)
14924 !            gelc(k,i)=gelc(k,i)+ghalf
14925 !            gelc(k,j)=gelc(k,j)+ghalf
14926 !          enddo
14927 ! 9/28/08 AL Gradient compotents will be summed only at the end
14928           do k=1,3
14929             gelc_long(k,j)=gelc(k,j)+ggg(k)
14930             gelc_long(k,i)=gelc(k,i)-ggg(k)
14931           enddo
14932 !
14933 ! Loop over residues i+1 thru j-1.
14934 !
14935 !grad          do k=i+1,j-1
14936 !grad            do l=1,3
14937 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14938 !grad            enddo
14939 !grad          enddo
14940 ! 9/28/08 AL Gradient compotents will be summed only at the end
14941           ggg(1)=facvdw*xj
14942           ggg(2)=facvdw*yj
14943           ggg(3)=facvdw*zj
14944           do k=1,3
14945             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14946             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14947           enddo
14948 #endif
14949 !
14950 ! Angular part
14951 !
14952           ecosa=2.0D0*fac3*fac1+fac4
14953           fac4=-3.0D0*fac4
14954           fac3=-6.0D0*fac3
14955           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
14956           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
14957           do k=1,3
14958             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14959             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14960           enddo
14961 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
14962 !d   &          (dcosg(k),k=1,3)
14963           do k=1,3
14964             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
14965           enddo
14966 !          do k=1,3
14967 !            ghalf=0.5D0*ggg(k)
14968 !            gelc(k,i)=gelc(k,i)+ghalf
14969 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
14970 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14971 !            gelc(k,j)=gelc(k,j)+ghalf
14972 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
14973 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14974 !          enddo
14975 !grad          do k=i+1,j-1
14976 !grad            do l=1,3
14977 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14978 !grad            enddo
14979 !grad          enddo
14980           do k=1,3
14981             gelc(k,i)=gelc(k,i) &
14982                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14983                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
14984                      *sss_ele_cut
14985             gelc(k,j)=gelc(k,j) &
14986                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14987                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14988                      *sss_ele_cut
14989             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14990             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14991           enddo
14992           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14993               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
14994               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14995 !
14996 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
14997 !   energy of a peptide unit is assumed in the form of a second-order
14998 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
14999 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
15000 !   are computed for EVERY pair of non-contiguous peptide groups.
15001 !
15002           if (j.lt.nres-1) then
15003             j1=j+1
15004             j2=j-1
15005           else
15006             j1=j-1
15007             j2=j-2
15008           endif
15009           kkk=0
15010           do k=1,2
15011             do l=1,2
15012               kkk=kkk+1
15013               muij(kkk)=mu(k,i)*mu(l,j)
15014             enddo
15015           enddo
15016 !d         write (iout,*) 'EELEC: i',i,' j',j
15017 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
15018 !d          write(iout,*) 'muij',muij
15019           ury=scalar(uy(1,i),erij)
15020           urz=scalar(uz(1,i),erij)
15021           vry=scalar(uy(1,j),erij)
15022           vrz=scalar(uz(1,j),erij)
15023           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
15024           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
15025           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
15026           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
15027           fac=dsqrt(-ael6i)*r3ij
15028           a22=a22*fac
15029           a23=a23*fac
15030           a32=a32*fac
15031           a33=a33*fac
15032 !d          write (iout,'(4i5,4f10.5)')
15033 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
15034 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
15035 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
15036 !d     &      uy(:,j),uz(:,j)
15037 !d          write (iout,'(4f10.5)')
15038 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
15039 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
15040 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
15041 !d           write (iout,'(9f10.5/)')
15042 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
15043 ! Derivatives of the elements of A in virtual-bond vectors
15044           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
15045           do k=1,3
15046             uryg(k,1)=scalar(erder(1,k),uy(1,i))
15047             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
15048             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
15049             urzg(k,1)=scalar(erder(1,k),uz(1,i))
15050             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
15051             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
15052             vryg(k,1)=scalar(erder(1,k),uy(1,j))
15053             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
15054             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
15055             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
15056             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
15057             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
15058           enddo
15059 ! Compute radial contributions to the gradient
15060           facr=-3.0d0*rrmij
15061           a22der=a22*facr
15062           a23der=a23*facr
15063           a32der=a32*facr
15064           a33der=a33*facr
15065           agg(1,1)=a22der*xj
15066           agg(2,1)=a22der*yj
15067           agg(3,1)=a22der*zj
15068           agg(1,2)=a23der*xj
15069           agg(2,2)=a23der*yj
15070           agg(3,2)=a23der*zj
15071           agg(1,3)=a32der*xj
15072           agg(2,3)=a32der*yj
15073           agg(3,3)=a32der*zj
15074           agg(1,4)=a33der*xj
15075           agg(2,4)=a33der*yj
15076           agg(3,4)=a33der*zj
15077 ! Add the contributions coming from er
15078           fac3=-3.0d0*fac
15079           do k=1,3
15080             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
15081             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
15082             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
15083             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
15084           enddo
15085           do k=1,3
15086 ! Derivatives in DC(i)
15087 !grad            ghalf1=0.5d0*agg(k,1)
15088 !grad            ghalf2=0.5d0*agg(k,2)
15089 !grad            ghalf3=0.5d0*agg(k,3)
15090 !grad            ghalf4=0.5d0*agg(k,4)
15091             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
15092             -3.0d0*uryg(k,2)*vry)!+ghalf1
15093             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
15094             -3.0d0*uryg(k,2)*vrz)!+ghalf2
15095             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
15096             -3.0d0*urzg(k,2)*vry)!+ghalf3
15097             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
15098             -3.0d0*urzg(k,2)*vrz)!+ghalf4
15099 ! Derivatives in DC(i+1)
15100             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
15101             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
15102             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
15103             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
15104             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
15105             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
15106             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
15107             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
15108 ! Derivatives in DC(j)
15109             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
15110             -3.0d0*vryg(k,2)*ury)!+ghalf1
15111             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
15112             -3.0d0*vrzg(k,2)*ury)!+ghalf2
15113             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
15114             -3.0d0*vryg(k,2)*urz)!+ghalf3
15115             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
15116             -3.0d0*vrzg(k,2)*urz)!+ghalf4
15117 ! Derivatives in DC(j+1) or DC(nres-1)
15118             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
15119             -3.0d0*vryg(k,3)*ury)
15120             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
15121             -3.0d0*vrzg(k,3)*ury)
15122             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
15123             -3.0d0*vryg(k,3)*urz)
15124             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
15125             -3.0d0*vrzg(k,3)*urz)
15126 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
15127 !grad              do l=1,4
15128 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
15129 !grad              enddo
15130 !grad            endif
15131           enddo
15132           acipa(1,1)=a22
15133           acipa(1,2)=a23
15134           acipa(2,1)=a32
15135           acipa(2,2)=a33
15136           a22=-a22
15137           a23=-a23
15138           do l=1,2
15139             do k=1,3
15140               agg(k,l)=-agg(k,l)
15141               aggi(k,l)=-aggi(k,l)
15142               aggi1(k,l)=-aggi1(k,l)
15143               aggj(k,l)=-aggj(k,l)
15144               aggj1(k,l)=-aggj1(k,l)
15145             enddo
15146           enddo
15147           if (j.lt.nres-1) then
15148             a22=-a22
15149             a32=-a32
15150             do l=1,3,2
15151               do k=1,3
15152                 agg(k,l)=-agg(k,l)
15153                 aggi(k,l)=-aggi(k,l)
15154                 aggi1(k,l)=-aggi1(k,l)
15155                 aggj(k,l)=-aggj(k,l)
15156                 aggj1(k,l)=-aggj1(k,l)
15157               enddo
15158             enddo
15159           else
15160             a22=-a22
15161             a23=-a23
15162             a32=-a32
15163             a33=-a33
15164             do l=1,4
15165               do k=1,3
15166                 agg(k,l)=-agg(k,l)
15167                 aggi(k,l)=-aggi(k,l)
15168                 aggi1(k,l)=-aggi1(k,l)
15169                 aggj(k,l)=-aggj(k,l)
15170                 aggj1(k,l)=-aggj1(k,l)
15171               enddo
15172             enddo
15173           endif
15174           ENDIF ! WCORR
15175           IF (wel_loc.gt.0.0d0) THEN
15176 ! Contribution to the local-electrostatic energy coming from the i-j pair
15177           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
15178            +a33*muij(4)
15179 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
15180 !           print *,"EELLOC",i,gel_loc_loc(i-1)
15181           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
15182                   'eelloc',i,j,eel_loc_ij
15183 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
15184
15185           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
15186 ! Partial derivatives in virtual-bond dihedral angles gamma
15187           if (i.gt.1) &
15188           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
15189                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
15190                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
15191                  *sss_ele_cut
15192           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
15193                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
15194                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
15195                  *sss_ele_cut
15196            xtemp(1)=xj
15197            xtemp(2)=yj
15198            xtemp(3)=zj
15199
15200 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
15201           do l=1,3
15202             ggg(l)=(agg(l,1)*muij(1)+ &
15203                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
15204             *sss_ele_cut &
15205              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
15206
15207             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
15208             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
15209 !grad            ghalf=0.5d0*ggg(l)
15210 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
15211 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
15212           enddo
15213 !grad          do k=i+1,j2
15214 !grad            do l=1,3
15215 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
15216 !grad            enddo
15217 !grad          enddo
15218 ! Remaining derivatives of eello
15219           do l=1,3
15220             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
15221                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
15222             *sss_ele_cut
15223
15224             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
15225                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
15226             *sss_ele_cut
15227
15228             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
15229                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
15230             *sss_ele_cut
15231
15232             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
15233                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
15234             *sss_ele_cut
15235
15236           enddo
15237           ENDIF
15238 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
15239 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
15240           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
15241              .and. num_conti.le.maxconts) then
15242 !            write (iout,*) i,j," entered corr"
15243 !
15244 ! Calculate the contact function. The ith column of the array JCONT will
15245 ! contain the numbers of atoms that make contacts with the atom I (of numbers
15246 ! greater than I). The arrays FACONT and GACONT will contain the values of
15247 ! the contact function and its derivative.
15248 !           r0ij=1.02D0*rpp(iteli,itelj)
15249 !           r0ij=1.11D0*rpp(iteli,itelj)
15250             r0ij=2.20D0*rpp(iteli,itelj)
15251 !           r0ij=1.55D0*rpp(iteli,itelj)
15252             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
15253 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15254             if (fcont.gt.0.0D0) then
15255               num_conti=num_conti+1
15256               if (num_conti.gt.maxconts) then
15257 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15258                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
15259                                ' will skip next contacts for this conf.',num_conti
15260               else
15261                 jcont_hb(num_conti,i)=j
15262 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
15263 !d     &           " jcont_hb",jcont_hb(num_conti,i)
15264                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
15265                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15266 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
15267 !  terms.
15268                 d_cont(num_conti,i)=rij
15269 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
15270 !     --- Electrostatic-interaction matrix ---
15271                 a_chuj(1,1,num_conti,i)=a22
15272                 a_chuj(1,2,num_conti,i)=a23
15273                 a_chuj(2,1,num_conti,i)=a32
15274                 a_chuj(2,2,num_conti,i)=a33
15275 !     --- Gradient of rij
15276                 do kkk=1,3
15277                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
15278                 enddo
15279                 kkll=0
15280                 do k=1,2
15281                   do l=1,2
15282                     kkll=kkll+1
15283                     do m=1,3
15284                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
15285                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
15286                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
15287                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
15288                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
15289                     enddo
15290                   enddo
15291                 enddo
15292                 ENDIF
15293                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
15294 ! Calculate contact energies
15295                 cosa4=4.0D0*cosa
15296                 wij=cosa-3.0D0*cosb*cosg
15297                 cosbg1=cosb+cosg
15298                 cosbg2=cosb-cosg
15299 !               fac3=dsqrt(-ael6i)/r0ij**3
15300                 fac3=dsqrt(-ael6i)*r3ij
15301 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
15302                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
15303                 if (ees0tmp.gt.0) then
15304                   ees0pij=dsqrt(ees0tmp)
15305                 else
15306                   ees0pij=0
15307                 endif
15308 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
15309                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
15310                 if (ees0tmp.gt.0) then
15311                   ees0mij=dsqrt(ees0tmp)
15312                 else
15313                   ees0mij=0
15314                 endif
15315 !               ees0mij=0.0D0
15316                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
15317                      *sss_ele_cut
15318
15319                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
15320                      *sss_ele_cut
15321
15322 ! Diagnostics. Comment out or remove after debugging!
15323 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
15324 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
15325 !               ees0m(num_conti,i)=0.0D0
15326 ! End diagnostics.
15327 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
15328 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
15329 ! Angular derivatives of the contact function
15330                 ees0pij1=fac3/ees0pij
15331                 ees0mij1=fac3/ees0mij
15332                 fac3p=-3.0D0*fac3*rrmij
15333                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
15334                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
15335 !               ees0mij1=0.0D0
15336                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
15337                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
15338                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
15339                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
15340                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
15341                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
15342                 ecosap=ecosa1+ecosa2
15343                 ecosbp=ecosb1+ecosb2
15344                 ecosgp=ecosg1+ecosg2
15345                 ecosam=ecosa1-ecosa2
15346                 ecosbm=ecosb1-ecosb2
15347                 ecosgm=ecosg1-ecosg2
15348 ! Diagnostics
15349 !               ecosap=ecosa1
15350 !               ecosbp=ecosb1
15351 !               ecosgp=ecosg1
15352 !               ecosam=0.0D0
15353 !               ecosbm=0.0D0
15354 !               ecosgm=0.0D0
15355 ! End diagnostics
15356                 facont_hb(num_conti,i)=fcont
15357                 fprimcont=fprimcont/rij
15358 !d              facont_hb(num_conti,i)=1.0D0
15359 ! Following line is for diagnostics.
15360 !d              fprimcont=0.0D0
15361                 do k=1,3
15362                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15363                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15364                 enddo
15365                 do k=1,3
15366                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
15367                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
15368                 enddo
15369 !                gggp(1)=gggp(1)+ees0pijp*xj
15370 !                gggp(2)=gggp(2)+ees0pijp*yj
15371 !                gggp(3)=gggp(3)+ees0pijp*zj
15372 !                gggm(1)=gggm(1)+ees0mijp*xj
15373 !                gggm(2)=gggm(2)+ees0mijp*yj
15374 !                gggm(3)=gggm(3)+ees0mijp*zj
15375                 gggp(1)=gggp(1)+ees0pijp*xj &
15376                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15377                 gggp(2)=gggp(2)+ees0pijp*yj &
15378                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15379                 gggp(3)=gggp(3)+ees0pijp*zj &
15380                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15381
15382                 gggm(1)=gggm(1)+ees0mijp*xj &
15383                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15384
15385                 gggm(2)=gggm(2)+ees0mijp*yj &
15386                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15387
15388                 gggm(3)=gggm(3)+ees0mijp*zj &
15389                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15390
15391 ! Derivatives due to the contact function
15392                 gacont_hbr(1,num_conti,i)=fprimcont*xj
15393                 gacont_hbr(2,num_conti,i)=fprimcont*yj
15394                 gacont_hbr(3,num_conti,i)=fprimcont*zj
15395                 do k=1,3
15396 !
15397 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
15398 !          following the change of gradient-summation algorithm.
15399 !
15400 !grad                  ghalfp=0.5D0*gggp(k)
15401 !grad                  ghalfm=0.5D0*gggm(k)
15402 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
15403 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15404 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15405 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
15406 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15407 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15408 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
15409 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
15410 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15411 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15412 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
15413 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15414 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15415 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
15416                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
15417                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15418                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15419                      *sss_ele_cut
15420
15421                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
15422                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15423                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15424                      *sss_ele_cut
15425
15426                   gacontp_hb3(k,num_conti,i)=gggp(k) &
15427                      *sss_ele_cut
15428
15429                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
15430                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15431                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15432                      *sss_ele_cut
15433
15434                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
15435                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15436                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
15437                      *sss_ele_cut
15438
15439                   gacontm_hb3(k,num_conti,i)=gggm(k) &
15440                      *sss_ele_cut
15441
15442                 enddo
15443               ENDIF ! wcorr
15444               endif  ! num_conti.le.maxconts
15445             endif  ! fcont.gt.0
15446           endif    ! j.gt.i+1
15447           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
15448             do k=1,4
15449               do l=1,3
15450                 ghalf=0.5d0*agg(l,k)
15451                 aggi(l,k)=aggi(l,k)+ghalf
15452                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
15453                 aggj(l,k)=aggj(l,k)+ghalf
15454               enddo
15455             enddo
15456             if (j.eq.nres-1 .and. i.lt.j-2) then
15457               do k=1,4
15458                 do l=1,3
15459                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
15460                 enddo
15461               enddo
15462             endif
15463           endif
15464  128      continue
15465 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
15466       return
15467       end subroutine eelecij_scale
15468 !-----------------------------------------------------------------------------
15469       subroutine evdwpp_short(evdw1)
15470 !
15471 ! Compute Evdwpp
15472 !
15473 !      implicit real*8 (a-h,o-z)
15474 !      include 'DIMENSIONS'
15475 !      include 'COMMON.CONTROL'
15476 !      include 'COMMON.IOUNITS'
15477 !      include 'COMMON.GEO'
15478 !      include 'COMMON.VAR'
15479 !      include 'COMMON.LOCAL'
15480 !      include 'COMMON.CHAIN'
15481 !      include 'COMMON.DERIV'
15482 !      include 'COMMON.INTERACT'
15483 !      include 'COMMON.CONTACTS'
15484 !      include 'COMMON.TORSION'
15485 !      include 'COMMON.VECTORS'
15486 !      include 'COMMON.FFIELD'
15487       real(kind=8),dimension(3) :: ggg
15488 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15489 #ifdef MOMENT
15490       real(kind=8) :: scal_el=1.0d0
15491 #else
15492       real(kind=8) :: scal_el=0.5d0
15493 #endif
15494 !el local variables
15495       integer :: i,j,k,iteli,itelj,num_conti,isubchap
15496       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
15497       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
15498                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15499                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
15500       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15501                     dist_temp, dist_init,sss_grad,sslipi,ssgradlipi,&
15502                    sslipj,ssgradlipj,faclipij2
15503       integer xshift,yshift,zshift
15504
15505
15506       evdw1=0.0D0
15507 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
15508 !     & " iatel_e_vdw",iatel_e_vdw
15509       call flush(iout)
15510       do i=iatel_s_vdw,iatel_e_vdw
15511         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
15512         dxi=dc(1,i)
15513         dyi=dc(2,i)
15514         dzi=dc(3,i)
15515         dx_normi=dc_norm(1,i)
15516         dy_normi=dc_norm(2,i)
15517         dz_normi=dc_norm(3,i)
15518         xmedi=c(1,i)+0.5d0*dxi
15519         ymedi=c(2,i)+0.5d0*dyi
15520         zmedi=c(3,i)+0.5d0*dzi
15521         call to_box(xmedi,ymedi,zmedi)
15522         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
15523         num_conti=0
15524 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
15525 !     &   ' ielend',ielend_vdw(i)
15526         call flush(iout)
15527         do j=ielstart_vdw(i),ielend_vdw(i)
15528           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15529 !el          ind=ind+1
15530           iteli=itel(i)
15531           itelj=itel(j)
15532           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15533           aaa=app(iteli,itelj)
15534           bbb=bpp(iteli,itelj)
15535           dxj=dc(1,j)
15536           dyj=dc(2,j)
15537           dzj=dc(3,j)
15538           dx_normj=dc_norm(1,j)
15539           dy_normj=dc_norm(2,j)
15540           dz_normj=dc_norm(3,j)
15541 !          xj=c(1,j)+0.5D0*dxj-xmedi
15542 !          yj=c(2,j)+0.5D0*dyj-ymedi
15543 !          zj=c(3,j)+0.5D0*dzj-zmedi
15544           xj=c(1,j)+0.5D0*dxj
15545           yj=c(2,j)+0.5D0*dyj
15546           zj=c(3,j)+0.5D0*dzj
15547           call to_box(xj,yj,zj)
15548           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15549           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
15550           xj=boxshift(xj-xmedi,boxxsize)
15551           yj=boxshift(yj-ymedi,boxysize)
15552           zj=boxshift(zj-zmedi,boxzsize)
15553           rij=xj*xj+yj*yj+zj*zj
15554           rrmij=1.0D0/rij
15555           rij=dsqrt(rij)
15556           sss=sscale(rij/rpp(iteli,itelj))
15557             sss_ele_cut=sscale_ele(rij)
15558             sss_ele_grad=sscagrad_ele(rij)
15559             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15560             if (sss_ele_cut.le.0.0) cycle
15561           if (sss.gt.0.0d0) then
15562             rmij=1.0D0/rij
15563             r3ij=rrmij*rmij
15564             r6ij=r3ij*r3ij
15565             ev1=aaa*r6ij*r6ij
15566 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15567             if (j.eq.i+2) ev1=scal_el*ev1
15568             ev2=bbb*r6ij
15569             evdwij=ev1+ev2
15570             if (energy_dec) then
15571               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15572             endif
15573             evdw1=evdw1+evdwij*sss*sss_ele_cut
15574 !
15575 ! Calculate contributions to the Cartesian gradient.
15576 !
15577             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
15578 !            ggg(1)=facvdw*xj
15579 !            ggg(2)=facvdw*yj
15580 !            ggg(3)=facvdw*zj
15581           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
15582           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15583           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
15584           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15585           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
15586           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15587
15588             do k=1,3
15589               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15590               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15591             enddo
15592           endif
15593         enddo ! j
15594       enddo   ! i
15595       return
15596       end subroutine evdwpp_short
15597 !-----------------------------------------------------------------------------
15598       subroutine escp_long(evdw2,evdw2_14)
15599 !
15600 ! This subroutine calculates the excluded-volume interaction energy between
15601 ! peptide-group centers and side chains and its gradient in virtual-bond and
15602 ! side-chain vectors.
15603 !
15604 !      implicit real*8 (a-h,o-z)
15605 !      include 'DIMENSIONS'
15606 !      include 'COMMON.GEO'
15607 !      include 'COMMON.VAR'
15608 !      include 'COMMON.LOCAL'
15609 !      include 'COMMON.CHAIN'
15610 !      include 'COMMON.DERIV'
15611 !      include 'COMMON.INTERACT'
15612 !      include 'COMMON.FFIELD'
15613 !      include 'COMMON.IOUNITS'
15614 !      include 'COMMON.CONTROL'
15615       real(kind=8),dimension(3) :: ggg
15616 !el local variables
15617       integer :: i,iint,j,k,iteli,itypj,subchap
15618       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15619       real(kind=8) :: evdw2,evdw2_14,evdwij
15620       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15621                     dist_temp, dist_init
15622
15623       evdw2=0.0D0
15624       evdw2_14=0.0d0
15625 !d    print '(a)','Enter ESCP'
15626 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15627       do i=iatscp_s,iatscp_e
15628         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15629         iteli=itel(i)
15630         xi=0.5D0*(c(1,i)+c(1,i+1))
15631         yi=0.5D0*(c(2,i)+c(2,i+1))
15632         zi=0.5D0*(c(3,i)+c(3,i+1))
15633         call to_box(xi,yi,zi)
15634         do iint=1,nscp_gr(i)
15635
15636         do j=iscpstart(i,iint),iscpend(i,iint)
15637           itypj=itype(j,1)
15638           if (itypj.eq.ntyp1) cycle
15639 ! Uncomment following three lines for SC-p interactions
15640 !         xj=c(1,nres+j)-xi
15641 !         yj=c(2,nres+j)-yi
15642 !         zj=c(3,nres+j)-zi
15643 ! Uncomment following three lines for Ca-p interactions
15644           xj=c(1,j)
15645           yj=c(2,j)
15646           zj=c(3,j)
15647           call to_box(xj,yj,zj)
15648           xj=boxshift(xj-xi,boxxsize)
15649           yj=boxshift(yj-yi,boxysize)
15650           zj=boxshift(zj-zi,boxzsize)
15651           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15652
15653           rij=dsqrt(1.0d0/rrij)
15654             sss_ele_cut=sscale_ele(rij)
15655             sss_ele_grad=sscagrad_ele(rij)
15656 !            print *,sss_ele_cut,sss_ele_grad,&
15657 !            (rij),r_cut_ele,rlamb_ele
15658             if (sss_ele_cut.le.0.0) cycle
15659           sss=sscale((rij/rscp(itypj,iteli)))
15660           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15661           if (sss.lt.1.0d0) then
15662
15663             fac=rrij**expon2
15664             e1=fac*fac*aad(itypj,iteli)
15665             e2=fac*bad(itypj,iteli)
15666             if (iabs(j-i) .le. 2) then
15667               e1=scal14*e1
15668               e2=scal14*e2
15669               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
15670             endif
15671             evdwij=e1+e2
15672             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
15673             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15674                 'evdw2',i,j,sss,evdwij
15675 !
15676 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15677 !
15678             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
15679             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
15680             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15681             ggg(1)=xj*fac
15682             ggg(2)=yj*fac
15683             ggg(3)=zj*fac
15684 ! Uncomment following three lines for SC-p interactions
15685 !           do k=1,3
15686 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15687 !           enddo
15688 ! Uncomment following line for SC-p interactions
15689 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15690             do k=1,3
15691               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15692               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15693             enddo
15694           endif
15695         enddo
15696
15697         enddo ! iint
15698       enddo ! i
15699       do i=1,nct
15700         do j=1,3
15701           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15702           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15703           gradx_scp(j,i)=expon*gradx_scp(j,i)
15704         enddo
15705       enddo
15706 !******************************************************************************
15707 !
15708 !                              N O T E !!!
15709 !
15710 ! To save time the factor EXPON has been extracted from ALL components
15711 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15712 ! use!
15713 !
15714 !******************************************************************************
15715       return
15716       end subroutine escp_long
15717 !-----------------------------------------------------------------------------
15718       subroutine escp_short(evdw2,evdw2_14)
15719 !
15720 ! This subroutine calculates the excluded-volume interaction energy between
15721 ! peptide-group centers and side chains and its gradient in virtual-bond and
15722 ! side-chain vectors.
15723 !
15724 !      implicit real*8 (a-h,o-z)
15725 !      include 'DIMENSIONS'
15726 !      include 'COMMON.GEO'
15727 !      include 'COMMON.VAR'
15728 !      include 'COMMON.LOCAL'
15729 !      include 'COMMON.CHAIN'
15730 !      include 'COMMON.DERIV'
15731 !      include 'COMMON.INTERACT'
15732 !      include 'COMMON.FFIELD'
15733 !      include 'COMMON.IOUNITS'
15734 !      include 'COMMON.CONTROL'
15735       real(kind=8),dimension(3) :: ggg
15736 !el local variables
15737       integer :: i,iint,j,k,iteli,itypj,subchap
15738       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15739       real(kind=8) :: evdw2,evdw2_14,evdwij
15740       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15741                     dist_temp, dist_init
15742
15743       evdw2=0.0D0
15744       evdw2_14=0.0d0
15745 !d    print '(a)','Enter ESCP'
15746 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15747       do i=iatscp_s,iatscp_e
15748         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15749         iteli=itel(i)
15750         xi=0.5D0*(c(1,i)+c(1,i+1))
15751         yi=0.5D0*(c(2,i)+c(2,i+1))
15752         zi=0.5D0*(c(3,i)+c(3,i+1))
15753         call to_box(xi,yi,zi)
15754         if (zi.lt.0) zi=zi+boxzsize
15755
15756         do iint=1,nscp_gr(i)
15757
15758         do j=iscpstart(i,iint),iscpend(i,iint)
15759           itypj=itype(j,1)
15760           if (itypj.eq.ntyp1) cycle
15761 ! Uncomment following three lines for SC-p interactions
15762 !         xj=c(1,nres+j)-xi
15763 !         yj=c(2,nres+j)-yi
15764 !         zj=c(3,nres+j)-zi
15765 ! Uncomment following three lines for Ca-p interactions
15766 !          xj=c(1,j)-xi
15767 !          yj=c(2,j)-yi
15768 !          zj=c(3,j)-zi
15769           xj=c(1,j)
15770           yj=c(2,j)
15771           zj=c(3,j)
15772           call to_box(xj,yj,zj)
15773           xj=boxshift(xj-xi,boxxsize)
15774           yj=boxshift(yj-yi,boxysize)
15775           zj=boxshift(zj-zi,boxzsize)
15776           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15777           rij=dsqrt(1.0d0/rrij)
15778             sss_ele_cut=sscale_ele(rij)
15779             sss_ele_grad=sscagrad_ele(rij)
15780 !            print *,sss_ele_cut,sss_ele_grad,&
15781 !            (rij),r_cut_ele,rlamb_ele
15782             if (sss_ele_cut.le.0.0) cycle
15783           sss=sscale(rij/rscp(itypj,iteli))
15784           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15785           if (sss.gt.0.0d0) then
15786
15787             fac=rrij**expon2
15788             e1=fac*fac*aad(itypj,iteli)
15789             e2=fac*bad(itypj,iteli)
15790             if (iabs(j-i) .le. 2) then
15791               e1=scal14*e1
15792               e2=scal14*e2
15793               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
15794             endif
15795             evdwij=e1+e2
15796             evdw2=evdw2+evdwij*sss*sss_ele_cut
15797             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15798                 'evdw2',i,j,sss,evdwij
15799 !
15800 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15801 !
15802             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
15803             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
15804             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15805
15806             ggg(1)=xj*fac
15807             ggg(2)=yj*fac
15808             ggg(3)=zj*fac
15809 ! Uncomment following three lines for SC-p interactions
15810 !           do k=1,3
15811 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15812 !           enddo
15813 ! Uncomment following line for SC-p interactions
15814 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15815             do k=1,3
15816               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15817               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15818             enddo
15819           endif
15820         enddo
15821
15822         enddo ! iint
15823       enddo ! i
15824       do i=1,nct
15825         do j=1,3
15826           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15827           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15828           gradx_scp(j,i)=expon*gradx_scp(j,i)
15829         enddo
15830       enddo
15831 !******************************************************************************
15832 !
15833 !                              N O T E !!!
15834 !
15835 ! To save time the factor EXPON has been extracted from ALL components
15836 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15837 ! use!
15838 !
15839 !******************************************************************************
15840       return
15841       end subroutine escp_short
15842 !-----------------------------------------------------------------------------
15843 ! energy_p_new-sep_barrier.F
15844 !-----------------------------------------------------------------------------
15845       subroutine sc_grad_scale(scalfac)
15846 !      implicit real*8 (a-h,o-z)
15847       use calc_data
15848 !      include 'DIMENSIONS'
15849 !      include 'COMMON.CHAIN'
15850 !      include 'COMMON.DERIV'
15851 !      include 'COMMON.CALC'
15852 !      include 'COMMON.IOUNITS'
15853       real(kind=8),dimension(3) :: dcosom1,dcosom2
15854       real(kind=8) :: scalfac
15855 !el local variables
15856 !      integer :: i,j,k,l
15857
15858       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15859       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15860       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
15861            -2.0D0*alf12*eps3der+sigder*sigsq_om12
15862 ! diagnostics only
15863 !      eom1=0.0d0
15864 !      eom2=0.0d0
15865 !      eom12=evdwij*eps1_om12
15866 ! end diagnostics
15867 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
15868 !     &  " sigder",sigder
15869 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
15870 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
15871       do k=1,3
15872         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
15873         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
15874       enddo
15875       do k=1,3
15876         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
15877          *sss_ele_cut
15878       enddo
15879 !      write (iout,*) "gg",(gg(k),k=1,3)
15880       do k=1,3
15881         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15882                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15883                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
15884                  *sss_ele_cut
15885         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15886                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15887                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
15888          *sss_ele_cut
15889 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
15890 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15891 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
15892 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15893       enddo
15894 !
15895 ! Calculate the components of the gradient in DC and X
15896 !
15897       do l=1,3
15898         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15899         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15900       enddo
15901       return
15902       end subroutine sc_grad_scale
15903 !-----------------------------------------------------------------------------
15904 ! energy_split-sep.F
15905 !-----------------------------------------------------------------------------
15906       subroutine etotal_long(energia)
15907 !
15908 ! Compute the long-range slow-varying contributions to the energy
15909 !
15910 !      implicit real*8 (a-h,o-z)
15911 !      include 'DIMENSIONS'
15912       use MD_data, only: totT,usampl,eq_time
15913 #ifndef ISNAN
15914       external proc_proc
15915 #ifdef WINPGI
15916 !MS$ATTRIBUTES C ::  proc_proc
15917 #endif
15918 #endif
15919 #ifdef MPI
15920       include "mpif.h"
15921       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
15922 #endif
15923 !      include 'COMMON.SETUP'
15924 !      include 'COMMON.IOUNITS'
15925 !      include 'COMMON.FFIELD'
15926 !      include 'COMMON.DERIV'
15927 !      include 'COMMON.INTERACT'
15928 !      include 'COMMON.SBRIDGE'
15929 !      include 'COMMON.CHAIN'
15930 !      include 'COMMON.VAR'
15931 !      include 'COMMON.LOCAL'
15932 !      include 'COMMON.MD'
15933       real(kind=8),dimension(0:n_ene) :: energia
15934 !el local variables
15935       integer :: i,n_corr,n_corr1,ierror,ierr
15936       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
15937                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
15938                   ecorr,ecorr5,ecorr6,eturn6,time00
15939 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
15940 !elwrite(iout,*)"in etotal long"
15941
15942       if (modecalc.eq.12.or.modecalc.eq.14) then
15943 #ifdef MPI
15944 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
15945 #else
15946         call int_from_cart1(.false.)
15947 #endif
15948       endif
15949 !elwrite(iout,*)"in etotal long"
15950
15951 #ifdef MPI
15952 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15953 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15954       call flush(iout)
15955       if (nfgtasks.gt.1) then
15956         time00=MPI_Wtime()
15957 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15958         if (fg_rank.eq.0) then
15959           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15960 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15961 !          call flush(iout)
15962 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15963 ! FG slaves as WEIGHTS array.
15964           weights_(1)=wsc
15965           weights_(2)=wscp
15966           weights_(3)=welec
15967           weights_(4)=wcorr
15968           weights_(5)=wcorr5
15969           weights_(6)=wcorr6
15970           weights_(7)=wel_loc
15971           weights_(8)=wturn3
15972           weights_(9)=wturn4
15973           weights_(10)=wturn6
15974           weights_(11)=wang
15975           weights_(12)=wscloc
15976           weights_(13)=wtor
15977           weights_(14)=wtor_d
15978           weights_(15)=wstrain
15979           weights_(16)=wvdwpp
15980           weights_(17)=wbond
15981           weights_(18)=scal14
15982           weights_(21)=wsccor
15983 ! FG Master broadcasts the WEIGHTS_ array
15984           call MPI_Bcast(weights_(1),n_ene,&
15985               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15986         else
15987 ! FG slaves receive the WEIGHTS array
15988           call MPI_Bcast(weights(1),n_ene,&
15989               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15990           wsc=weights(1)
15991           wscp=weights(2)
15992           welec=weights(3)
15993           wcorr=weights(4)
15994           wcorr5=weights(5)
15995           wcorr6=weights(6)
15996           wel_loc=weights(7)
15997           wturn3=weights(8)
15998           wturn4=weights(9)
15999           wturn6=weights(10)
16000           wang=weights(11)
16001           wscloc=weights(12)
16002           wtor=weights(13)
16003           wtor_d=weights(14)
16004           wstrain=weights(15)
16005           wvdwpp=weights(16)
16006           wbond=weights(17)
16007           scal14=weights(18)
16008           wsccor=weights(21)
16009         endif
16010         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
16011           king,FG_COMM,IERR)
16012          time_Bcast=time_Bcast+MPI_Wtime()-time00
16013          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
16014 !        call chainbuild_cart
16015 !        call int_from_cart1(.false.)
16016       endif
16017 !      write (iout,*) 'Processor',myrank,
16018 !     &  ' calling etotal_short ipot=',ipot
16019 !      call flush(iout)
16020 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16021 #endif
16022 !d    print *,'nnt=',nnt,' nct=',nct
16023 !
16024 !elwrite(iout,*)"in etotal long"
16025 ! Compute the side-chain and electrostatic interaction energy
16026 !
16027       goto (101,102,103,104,105,106) ipot
16028 ! Lennard-Jones potential.
16029   101 call elj_long(evdw)
16030 !d    print '(a)','Exit ELJ'
16031       goto 107
16032 ! Lennard-Jones-Kihara potential (shifted).
16033   102 call eljk_long(evdw)
16034       goto 107
16035 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16036   103 call ebp_long(evdw)
16037       goto 107
16038 ! Gay-Berne potential (shifted LJ, angular dependence).
16039   104 call egb_long(evdw)
16040       goto 107
16041 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16042   105 call egbv_long(evdw)
16043       goto 107
16044 ! Soft-sphere potential
16045   106 call e_softsphere(evdw)
16046 !
16047 ! Calculate electrostatic (H-bonding) energy of the main chain.
16048 !
16049   107 continue
16050       call vec_and_deriv
16051       if (ipot.lt.6) then
16052 #ifdef SPLITELE
16053          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
16054              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16055              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16056              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16057 #else
16058          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
16059              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16060              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16061              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16062 #endif
16063            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
16064          else
16065             ees=0
16066             evdw1=0
16067             eel_loc=0
16068             eello_turn3=0
16069             eello_turn4=0
16070          endif
16071       else
16072 !        write (iout,*) "Soft-spheer ELEC potential"
16073         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
16074          eello_turn4)
16075       endif
16076 !
16077 ! Calculate excluded-volume interaction energy between peptide groups
16078 ! and side chains.
16079 !
16080       if (ipot.lt.6) then
16081        if(wscp.gt.0d0) then
16082         call escp_long(evdw2,evdw2_14)
16083        else
16084         evdw2=0
16085         evdw2_14=0
16086        endif
16087       else
16088         call escp_soft_sphere(evdw2,evdw2_14)
16089       endif
16090 !
16091 ! 12/1/95 Multi-body terms
16092 !
16093       n_corr=0
16094       n_corr1=0
16095       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
16096           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
16097          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
16098 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
16099 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
16100       else
16101          ecorr=0.0d0
16102          ecorr5=0.0d0
16103          ecorr6=0.0d0
16104          eturn6=0.0d0
16105       endif
16106       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
16107          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
16108       endif
16109 !
16110 ! If performing constraint dynamics, call the constraint energy
16111 !  after the equilibration time
16112       if(usampl.and.totT.gt.eq_time) then
16113          call EconstrQ
16114          call Econstr_back
16115       else
16116          Uconst=0.0d0
16117          Uconst_back=0.0d0
16118       endif
16119 !
16120 ! Sum the energies
16121 !
16122       do i=1,n_ene
16123         energia(i)=0.0d0
16124       enddo
16125       energia(1)=evdw
16126 #ifdef SCP14
16127       energia(2)=evdw2-evdw2_14
16128       energia(18)=evdw2_14
16129 #else
16130       energia(2)=evdw2
16131       energia(18)=0.0d0
16132 #endif
16133 #ifdef SPLITELE
16134       energia(3)=ees
16135       energia(16)=evdw1
16136 #else
16137       energia(3)=ees+evdw1
16138       energia(16)=0.0d0
16139 #endif
16140       energia(4)=ecorr
16141       energia(5)=ecorr5
16142       energia(6)=ecorr6
16143       energia(7)=eel_loc
16144       energia(8)=eello_turn3
16145       energia(9)=eello_turn4
16146       energia(10)=eturn6
16147       energia(20)=Uconst+Uconst_back
16148       call sum_energy(energia,.true.)
16149 !      write (iout,*) "Exit ETOTAL_LONG"
16150       call flush(iout)
16151       return
16152       end subroutine etotal_long
16153 !-----------------------------------------------------------------------------
16154       subroutine etotal_short(energia)
16155 !
16156 ! Compute the short-range fast-varying contributions to the energy
16157 !
16158 !      implicit real*8 (a-h,o-z)
16159 !      include 'DIMENSIONS'
16160 #ifndef ISNAN
16161       external proc_proc
16162 #ifdef WINPGI
16163 !MS$ATTRIBUTES C ::  proc_proc
16164 #endif
16165 #endif
16166 #ifdef MPI
16167       include "mpif.h"
16168       integer :: ierror,ierr
16169       real(kind=8),dimension(n_ene) :: weights_
16170       real(kind=8) :: time00
16171 #endif
16172 !      include 'COMMON.SETUP'
16173 !      include 'COMMON.IOUNITS'
16174 !      include 'COMMON.FFIELD'
16175 !      include 'COMMON.DERIV'
16176 !      include 'COMMON.INTERACT'
16177 !      include 'COMMON.SBRIDGE'
16178 !      include 'COMMON.CHAIN'
16179 !      include 'COMMON.VAR'
16180 !      include 'COMMON.LOCAL'
16181       real(kind=8),dimension(0:n_ene) :: energia
16182 !el local variables
16183       integer :: i,nres6
16184       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
16185       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
16186       nres6=6*nres
16187
16188 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
16189 !      call flush(iout)
16190       if (modecalc.eq.12.or.modecalc.eq.14) then
16191 #ifdef MPI
16192         if (fg_rank.eq.0) call int_from_cart1(.false.)
16193 #else
16194         call int_from_cart1(.false.)
16195 #endif
16196       endif
16197 #ifdef MPI
16198 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
16199 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16200 !      call flush(iout)
16201       if (nfgtasks.gt.1) then
16202         time00=MPI_Wtime()
16203 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16204         if (fg_rank.eq.0) then
16205           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
16206 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16207 !          call flush(iout)
16208 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16209 ! FG slaves as WEIGHTS array.
16210           weights_(1)=wsc
16211           weights_(2)=wscp
16212           weights_(3)=welec
16213           weights_(4)=wcorr
16214           weights_(5)=wcorr5
16215           weights_(6)=wcorr6
16216           weights_(7)=wel_loc
16217           weights_(8)=wturn3
16218           weights_(9)=wturn4
16219           weights_(10)=wturn6
16220           weights_(11)=wang
16221           weights_(12)=wscloc
16222           weights_(13)=wtor
16223           weights_(14)=wtor_d
16224           weights_(15)=wstrain
16225           weights_(16)=wvdwpp
16226           weights_(17)=wbond
16227           weights_(18)=scal14
16228           weights_(21)=wsccor
16229 ! FG Master broadcasts the WEIGHTS_ array
16230           call MPI_Bcast(weights_(1),n_ene,&
16231               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16232         else
16233 ! FG slaves receive the WEIGHTS array
16234           call MPI_Bcast(weights(1),n_ene,&
16235               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16236           wsc=weights(1)
16237           wscp=weights(2)
16238           welec=weights(3)
16239           wcorr=weights(4)
16240           wcorr5=weights(5)
16241           wcorr6=weights(6)
16242           wel_loc=weights(7)
16243           wturn3=weights(8)
16244           wturn4=weights(9)
16245           wturn6=weights(10)
16246           wang=weights(11)
16247           wscloc=weights(12)
16248           wtor=weights(13)
16249           wtor_d=weights(14)
16250           wstrain=weights(15)
16251           wvdwpp=weights(16)
16252           wbond=weights(17)
16253           scal14=weights(18)
16254           wsccor=weights(21)
16255         endif
16256 !        write (iout,*),"Processor",myrank," BROADCAST weights"
16257         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
16258           king,FG_COMM,IERR)
16259 !        write (iout,*) "Processor",myrank," BROADCAST c"
16260         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
16261           king,FG_COMM,IERR)
16262 !        write (iout,*) "Processor",myrank," BROADCAST dc"
16263         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
16264           king,FG_COMM,IERR)
16265 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
16266         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
16267           king,FG_COMM,IERR)
16268 !        write (iout,*) "Processor",myrank," BROADCAST theta"
16269         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
16270           king,FG_COMM,IERR)
16271 !        write (iout,*) "Processor",myrank," BROADCAST phi"
16272         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
16273           king,FG_COMM,IERR)
16274 !        write (iout,*) "Processor",myrank," BROADCAST alph"
16275         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
16276           king,FG_COMM,IERR)
16277 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
16278         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
16279           king,FG_COMM,IERR)
16280 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
16281         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
16282           king,FG_COMM,IERR)
16283          time_Bcast=time_Bcast+MPI_Wtime()-time00
16284 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
16285       endif
16286 !      write (iout,*) 'Processor',myrank,
16287 !     &  ' calling etotal_short ipot=',ipot
16288 !      call flush(iout)
16289 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16290 #endif
16291 !      call int_from_cart1(.false.)
16292 !
16293 ! Compute the side-chain and electrostatic interaction energy
16294 !
16295       goto (101,102,103,104,105,106) ipot
16296 ! Lennard-Jones potential.
16297   101 call elj_short(evdw)
16298 !d    print '(a)','Exit ELJ'
16299       goto 107
16300 ! Lennard-Jones-Kihara potential (shifted).
16301   102 call eljk_short(evdw)
16302       goto 107
16303 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16304   103 call ebp_short(evdw)
16305       goto 107
16306 ! Gay-Berne potential (shifted LJ, angular dependence).
16307   104 call egb_short(evdw)
16308       goto 107
16309 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16310   105 call egbv_short(evdw)
16311       goto 107
16312 ! Soft-sphere potential - already dealt with in the long-range part
16313   106 evdw=0.0d0
16314 !  106 call e_softsphere_short(evdw)
16315 !
16316 ! Calculate electrostatic (H-bonding) energy of the main chain.
16317 !
16318   107 continue
16319 !
16320 ! Calculate the short-range part of Evdwpp
16321 !
16322       call evdwpp_short(evdw1)
16323 !
16324 ! Calculate the short-range part of ESCp
16325 !
16326       if (ipot.lt.6) then
16327        call escp_short(evdw2,evdw2_14)
16328       endif
16329 !
16330 ! Calculate the bond-stretching energy
16331 !
16332       call ebond(estr)
16333 !
16334 ! Calculate the disulfide-bridge and other energy and the contributions
16335 ! from other distance constraints.
16336       call edis(ehpb)
16337 !
16338 ! Calculate the virtual-bond-angle energy.
16339 !
16340 ! Calculate the SC local energy.
16341 !
16342       call vec_and_deriv
16343       call esc(escloc)
16344 !
16345       if (wang.gt.0d0) then
16346        if (tor_mode.eq.0) then
16347            call ebend(ebe)
16348        else
16349 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
16350 !C energy function
16351         call ebend_kcc(ebe)
16352        endif
16353       else
16354           ebe=0.0d0
16355       endif
16356       ethetacnstr=0.0d0
16357       if (with_theta_constr) call etheta_constr(ethetacnstr)
16358
16359 !       write(iout,*) "in etotal afer ebe",ipot
16360
16361 !      print *,"Processor",myrank," computed UB"
16362 !
16363 ! Calculate the SC local energy.
16364 !
16365       call esc(escloc)
16366 !elwrite(iout,*) "in etotal afer esc",ipot
16367 !      print *,"Processor",myrank," computed USC"
16368 !
16369 ! Calculate the virtual-bond torsional energy.
16370 !
16371 !d    print *,'nterm=',nterm
16372 !      if (wtor.gt.0) then
16373 !       call etor(etors,edihcnstr)
16374 !      else
16375 !       etors=0
16376 !       edihcnstr=0
16377 !      endif
16378       if (wtor.gt.0.0d0) then
16379          if (tor_mode.eq.0) then
16380            call etor(etors)
16381           else
16382 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
16383 !C energy function
16384         call etor_kcc(etors)
16385          endif
16386       else
16387            etors=0.0d0
16388       endif
16389       edihcnstr=0.0d0
16390       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
16391
16392 ! Calculate the virtual-bond torsional energy.
16393 !
16394 !
16395 ! 6/23/01 Calculate double-torsional energy
16396 !
16397       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
16398       call etor_d(etors_d)
16399       endif
16400 !
16401 ! 21/5/07 Calculate local sicdechain correlation energy
16402 !
16403       if (wsccor.gt.0.0d0) then
16404        call eback_sc_corr(esccor)
16405       else
16406        esccor=0.0d0
16407       endif
16408 !
16409 ! Put energy components into an array
16410 !
16411       do i=1,n_ene
16412        energia(i)=0.0d0
16413       enddo
16414       energia(1)=evdw
16415 #ifdef SCP14
16416       energia(2)=evdw2-evdw2_14
16417       energia(18)=evdw2_14
16418 #else
16419       energia(2)=evdw2
16420       energia(18)=0.0d0
16421 #endif
16422 #ifdef SPLITELE
16423       energia(16)=evdw1
16424 #else
16425       energia(3)=evdw1
16426 #endif
16427       energia(11)=ebe
16428       energia(12)=escloc
16429       energia(13)=etors
16430       energia(14)=etors_d
16431       energia(15)=ehpb
16432       energia(17)=estr
16433       energia(19)=edihcnstr
16434       energia(21)=esccor
16435 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
16436       call flush(iout)
16437       call sum_energy(energia,.true.)
16438 !      write (iout,*) "Exit ETOTAL_SHORT"
16439       call flush(iout)
16440       return
16441       end subroutine etotal_short
16442 !-----------------------------------------------------------------------------
16443 ! gnmr1.f
16444 !-----------------------------------------------------------------------------
16445       real(kind=8) function gnmr1(y,ymin,ymax)
16446 !      implicit none
16447       real(kind=8) :: y,ymin,ymax
16448       real(kind=8) :: wykl=4.0d0
16449       if (y.lt.ymin) then
16450         gnmr1=(ymin-y)**wykl/wykl
16451       else if (y.gt.ymax) then
16452        gnmr1=(y-ymax)**wykl/wykl
16453       else
16454        gnmr1=0.0d0
16455       endif
16456       return
16457       end function gnmr1
16458 !-----------------------------------------------------------------------------
16459       real(kind=8) function gnmr1prim(y,ymin,ymax)
16460 !      implicit none
16461       real(kind=8) :: y,ymin,ymax
16462       real(kind=8) :: wykl=4.0d0
16463       if (y.lt.ymin) then
16464        gnmr1prim=-(ymin-y)**(wykl-1)
16465       else if (y.gt.ymax) then
16466        gnmr1prim=(y-ymax)**(wykl-1)
16467       else
16468        gnmr1prim=0.0d0
16469       endif
16470       return
16471       end function gnmr1prim
16472 !----------------------------------------------------------------------------
16473       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
16474       real(kind=8) y,ymin,ymax,sigma
16475       real(kind=8) wykl /4.0d0/
16476       if (y.lt.ymin) then
16477         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
16478       else if (y.gt.ymax) then
16479        rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
16480       else
16481         rlornmr1=0.0d0
16482       endif
16483       return
16484       end function rlornmr1
16485 !------------------------------------------------------------------------------
16486       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
16487       real(kind=8) y,ymin,ymax,sigma
16488       real(kind=8) wykl /4.0d0/
16489       if (y.lt.ymin) then
16490         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
16491         ((ymin-y)**wykl+sigma**wykl)**2
16492       else if (y.gt.ymax) then
16493          rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
16494         ((y-ymax)**wykl+sigma**wykl)**2
16495       else
16496        rlornmr1prim=0.0d0
16497       endif
16498       return
16499       end function rlornmr1prim
16500
16501       real(kind=8) function harmonic(y,ymax)
16502 !      implicit none
16503       real(kind=8) :: y,ymax
16504       real(kind=8) :: wykl=2.0d0
16505       harmonic=(y-ymax)**wykl
16506       return
16507       end function harmonic
16508 !-----------------------------------------------------------------------------
16509       real(kind=8) function harmonicprim(y,ymax)
16510       real(kind=8) :: y,ymin,ymax
16511       real(kind=8) :: wykl=2.0d0
16512       harmonicprim=(y-ymax)*wykl
16513       return
16514       end function harmonicprim
16515 !-----------------------------------------------------------------------------
16516 ! gradient_p.F
16517 !-----------------------------------------------------------------------------
16518       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
16519
16520       use io_base, only:intout,briefout
16521 !      implicit real*8 (a-h,o-z)
16522 !      include 'DIMENSIONS'
16523 !      include 'COMMON.CHAIN'
16524 !      include 'COMMON.DERIV'
16525 !      include 'COMMON.VAR'
16526 !      include 'COMMON.INTERACT'
16527 !      include 'COMMON.FFIELD'
16528 !      include 'COMMON.MD'
16529 !      include 'COMMON.IOUNITS'
16530       real(kind=8),external :: ufparm
16531       integer :: uiparm(1)
16532       real(kind=8) :: urparm(1)
16533       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
16534       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
16535       integer :: n,nf,ind,ind1,i,k,j
16536 !
16537 ! This subroutine calculates total internal coordinate gradient.
16538 ! Depending on the number of function evaluations, either whole energy
16539 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
16540 ! internal coordinates are reevaluated or only the cartesian-in-internal
16541 ! coordinate derivatives are evaluated. The subroutine was designed to work
16542 ! with SUMSL.
16543 !
16544 !
16545       icg=mod(nf,2)+1
16546
16547 !d      print *,'grad',nf,icg
16548       if (nf-nfl+1) 20,30,40
16549    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
16550 !    write (iout,*) 'grad 20'
16551       if (nf.eq.0) return
16552       goto 40
16553    30 call var_to_geom(n,x)
16554       call chainbuild
16555 !    write (iout,*) 'grad 30'
16556 !
16557 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
16558 !
16559    40 call cartder
16560 !     write (iout,*) 'grad 40'
16561 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
16562 !
16563 ! Convert the Cartesian gradient into internal-coordinate gradient.
16564 !
16565       ind=0
16566       ind1=0
16567       do i=1,nres-2
16568       gthetai=0.0D0
16569       gphii=0.0D0
16570       do j=i+1,nres-1
16571         ind=ind+1
16572 !         ind=indmat(i,j)
16573 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16574        do k=1,3
16575        gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
16576         enddo
16577         do k=1,3
16578         gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
16579          enddo
16580        enddo
16581       do j=i+1,nres-1
16582         ind1=ind1+1
16583 !         ind1=indmat(i,j)
16584 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
16585         do k=1,3
16586           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
16587           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
16588           enddo
16589         enddo
16590       if (i.gt.1) g(i-1)=gphii
16591       if (n.gt.nphi) g(nphi+i)=gthetai
16592       enddo
16593       if (n.le.nphi+ntheta) goto 10
16594       do i=2,nres-1
16595       if (itype(i,1).ne.10) then
16596           galphai=0.0D0
16597         gomegai=0.0D0
16598         do k=1,3
16599           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
16600           enddo
16601         do k=1,3
16602           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
16603           enddo
16604           g(ialph(i,1))=galphai
16605         g(ialph(i,1)+nside)=gomegai
16606         endif
16607       enddo
16608 !
16609 ! Add the components corresponding to local energy terms.
16610 !
16611    10 continue
16612       do i=1,nvar
16613 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
16614         g(i)=g(i)+gloc(i,icg)
16615       enddo
16616 ! Uncomment following three lines for diagnostics.
16617 !d    call intout
16618 !elwrite(iout,*) "in gradient after calling intout"
16619 !d    call briefout(0,0.0d0)
16620 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
16621       return
16622       end subroutine gradient
16623 !-----------------------------------------------------------------------------
16624       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
16625
16626       use comm_chu
16627 !      implicit real*8 (a-h,o-z)
16628 !      include 'DIMENSIONS'
16629 !      include 'COMMON.DERIV'
16630 !      include 'COMMON.IOUNITS'
16631 !      include 'COMMON.GEO'
16632       integer :: n,nf
16633 !el      integer :: jjj
16634 !el      common /chuju/ jjj
16635       real(kind=8) :: energia(0:n_ene)
16636       integer :: uiparm(1)
16637       real(kind=8) :: urparm(1)
16638       real(kind=8) :: f
16639       real(kind=8),external :: ufparm
16640       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
16641 !     if (jjj.gt.0) then
16642 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16643 !     endif
16644       nfl=nf
16645       icg=mod(nf,2)+1
16646 !d      print *,'func',nf,nfl,icg
16647       call var_to_geom(n,x)
16648       call zerograd
16649       call chainbuild
16650 !d    write (iout,*) 'ETOTAL called from FUNC'
16651       call etotal(energia)
16652       call sum_gradient
16653       f=energia(0)
16654 !     if (jjj.gt.0) then
16655 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16656 !       write (iout,*) 'f=',etot
16657 !       jjj=0
16658 !     endif
16659       return
16660       end subroutine func
16661 !-----------------------------------------------------------------------------
16662       subroutine cartgrad
16663 !      implicit real*8 (a-h,o-z)
16664 !      include 'DIMENSIONS'
16665       use energy_data
16666       use MD_data, only: totT,usampl,eq_time
16667 #ifdef MPI
16668       include 'mpif.h'
16669 #endif
16670 !      include 'COMMON.CHAIN'
16671 !      include 'COMMON.DERIV'
16672 !      include 'COMMON.VAR'
16673 !      include 'COMMON.INTERACT'
16674 !      include 'COMMON.FFIELD'
16675 !      include 'COMMON.MD'
16676 !      include 'COMMON.IOUNITS'
16677 !      include 'COMMON.TIME1'
16678 !
16679       integer :: i,j
16680       real(kind=8) :: time00,time01
16681
16682 ! This subrouting calculates total Cartesian coordinate gradient.
16683 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
16684 !
16685 !#define DEBUG
16686 #ifdef TIMINGtime01
16687       time00=MPI_Wtime()
16688 #endif
16689       icg=1
16690       call sum_gradient
16691 #ifdef TIMING
16692 #endif
16693 !#define DEBUG
16694 !el      write (iout,*) "After sum_gradient"
16695 #ifdef DEBUG
16696       write (iout,*) "After sum_gradient"
16697       do i=1,nres-1
16698         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
16699         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
16700       enddo
16701 #endif
16702 !#undef DEBUG
16703 ! If performing constraint dynamics, add the gradients of the constraint energy
16704       if(usampl.and.totT.gt.eq_time) then
16705          do i=1,nct
16706            do j=1,3
16707              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
16708              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
16709            enddo
16710          enddo
16711          do i=1,nres-3
16712            gloc(i,icg)=gloc(i,icg)+dugamma(i)
16713          enddo
16714          do i=1,nres-2
16715            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
16716          enddo
16717       endif
16718 !elwrite (iout,*) "After sum_gradient"
16719 #ifdef TIMING
16720       time01=MPI_Wtime()
16721 #endif
16722       call intcartderiv
16723 !elwrite (iout,*) "After sum_gradient"
16724 #ifdef TIMING
16725       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
16726 #endif
16727 !     call checkintcartgrad
16728 !     write(iout,*) 'calling int_to_cart'
16729 !#define DEBUG
16730 #ifdef DEBUG
16731       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
16732 #endif
16733       do i=0,nct
16734         do j=1,3
16735           gcart(j,i)=gradc(j,i,icg)
16736           gxcart(j,i)=gradx(j,i,icg)
16737 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
16738         enddo
16739 #ifdef DEBUG
16740         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
16741           (gxcart(j,i),j=1,3),gloc(i,icg)
16742 #endif
16743       enddo
16744 #ifdef TIMING
16745       time01=MPI_Wtime()
16746 #endif
16747 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16748       call int_to_cart
16749 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16750
16751 #ifdef TIMING
16752             time_inttocart=time_inttocart+MPI_Wtime()-time01
16753 #endif
16754 #ifdef DEBUG
16755             write (iout,*) "gcart and gxcart after int_to_cart"
16756             do i=0,nres-1
16757             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
16758             (gxcart(j,i),j=1,3)
16759             enddo
16760 #endif
16761 !#undef DEBUG
16762 #ifdef CARGRAD
16763 #ifdef DEBUG
16764             write (iout,*) "CARGRAD"
16765 #endif
16766             do i=nres,0,-1
16767             do j=1,3
16768               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16769       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16770             enddo
16771       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
16772       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
16773             enddo
16774       ! Correction: dummy residues
16775             if (nnt.gt.1) then
16776               do j=1,3
16777       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
16778             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
16779             enddo
16780           endif
16781           if (nct.lt.nres) then
16782             do j=1,3
16783       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
16784             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
16785             enddo
16786           endif
16787 #endif
16788 #ifdef TIMING
16789           time_cartgrad=time_cartgrad+MPI_Wtime()-time00
16790 #endif
16791 !#undef DEBUG
16792           return
16793           end subroutine cartgrad
16794       !-----------------------------------------------------------------------------
16795           subroutine zerograd
16796       !      implicit real*8 (a-h,o-z)
16797       !      include 'DIMENSIONS'
16798       !      include 'COMMON.DERIV'
16799       !      include 'COMMON.CHAIN'
16800       !      include 'COMMON.VAR'
16801       !      include 'COMMON.MD'
16802       !      include 'COMMON.SCCOR'
16803       !
16804       !el local variables
16805           integer :: i,j,intertyp,k
16806       ! Initialize Cartesian-coordinate gradient
16807       !
16808       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
16809       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
16810
16811       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
16812       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
16813       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
16814       !      allocate(gradcorr_long(3,nres))
16815       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
16816       !      allocate(gcorr6_turn_long(3,nres))
16817       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
16818
16819       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
16820
16821       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
16822       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
16823
16824       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
16825       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
16826
16827       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
16828       !      allocate(gscloc(3,nres)) !(3,maxres)
16829       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
16830
16831
16832
16833       !      common /deriv_scloc/
16834       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
16835       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
16836       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
16837       !      common /mpgrad/
16838       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
16839
16840
16841
16842       !          gradc(j,i,icg)=0.0d0
16843       !          gradx(j,i,icg)=0.0d0
16844
16845       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
16846       !elwrite(iout,*) "icg",icg
16847           do i=-1,nres
16848           do j=1,3
16849             gvdwx(j,i)=0.0D0
16850             gradx_scp(j,i)=0.0D0
16851             gvdwc(j,i)=0.0D0
16852             gvdwc_scp(j,i)=0.0D0
16853             gvdwc_scpp(j,i)=0.0d0
16854             gelc(j,i)=0.0D0
16855             gelc_long(j,i)=0.0D0
16856             gradb(j,i)=0.0d0
16857             gradbx(j,i)=0.0d0
16858             gvdwpp(j,i)=0.0d0
16859             gel_loc(j,i)=0.0d0
16860             gel_loc_long(j,i)=0.0d0
16861             ghpbc(j,i)=0.0D0
16862             ghpbx(j,i)=0.0D0
16863             gcorr3_turn(j,i)=0.0d0
16864             gcorr4_turn(j,i)=0.0d0
16865             gradcorr(j,i)=0.0d0
16866             gradcorr_long(j,i)=0.0d0
16867             gradcorr5_long(j,i)=0.0d0
16868             gradcorr6_long(j,i)=0.0d0
16869             gcorr6_turn_long(j,i)=0.0d0
16870             gradcorr5(j,i)=0.0d0
16871             gradcorr6(j,i)=0.0d0
16872             gcorr6_turn(j,i)=0.0d0
16873             gsccorc(j,i)=0.0d0
16874             gsccorx(j,i)=0.0d0
16875             gradc(j,i,icg)=0.0d0
16876             gradx(j,i,icg)=0.0d0
16877             gscloc(j,i)=0.0d0
16878             gsclocx(j,i)=0.0d0
16879             gliptran(j,i)=0.0d0
16880             gliptranx(j,i)=0.0d0
16881             gliptranc(j,i)=0.0d0
16882             gshieldx(j,i)=0.0d0
16883             gshieldc(j,i)=0.0d0
16884             gshieldc_loc(j,i)=0.0d0
16885             gshieldx_ec(j,i)=0.0d0
16886             gshieldc_ec(j,i)=0.0d0
16887             gshieldc_loc_ec(j,i)=0.0d0
16888             gshieldx_t3(j,i)=0.0d0
16889             gshieldc_t3(j,i)=0.0d0
16890             gshieldc_loc_t3(j,i)=0.0d0
16891             gshieldx_t4(j,i)=0.0d0
16892             gshieldc_t4(j,i)=0.0d0
16893             gshieldc_loc_t4(j,i)=0.0d0
16894             gshieldx_ll(j,i)=0.0d0
16895             gshieldc_ll(j,i)=0.0d0
16896             gshieldc_loc_ll(j,i)=0.0d0
16897             gg_tube(j,i)=0.0d0
16898             gg_tube_sc(j,i)=0.0d0
16899             gradafm(j,i)=0.0d0
16900             gradb_nucl(j,i)=0.0d0
16901             gradbx_nucl(j,i)=0.0d0
16902             gvdwpp_nucl(j,i)=0.0d0
16903             gvdwpp(j,i)=0.0d0
16904             gelpp(j,i)=0.0d0
16905             gvdwpsb(j,i)=0.0d0
16906             gvdwpsb1(j,i)=0.0d0
16907             gvdwsbc(j,i)=0.0d0
16908             gvdwsbx(j,i)=0.0d0
16909             gelsbc(j,i)=0.0d0
16910             gradcorr_nucl(j,i)=0.0d0
16911             gradcorr3_nucl(j,i)=0.0d0
16912             gradxorr_nucl(j,i)=0.0d0
16913             gradxorr3_nucl(j,i)=0.0d0
16914             gelsbx(j,i)=0.0d0
16915             gsbloc(j,i)=0.0d0
16916             gsblocx(j,i)=0.0d0
16917             gradpepcat(j,i)=0.0d0
16918             gradpepcatx(j,i)=0.0d0
16919             gradcatcat(j,i)=0.0d0
16920             gvdwx_scbase(j,i)=0.0d0
16921             gvdwc_scbase(j,i)=0.0d0
16922             gvdwx_pepbase(j,i)=0.0d0
16923             gvdwc_pepbase(j,i)=0.0d0
16924             gvdwx_scpho(j,i)=0.0d0
16925             gvdwc_scpho(j,i)=0.0d0
16926             gvdwc_peppho(j,i)=0.0d0
16927           enddo
16928            enddo
16929           do i=0,nres
16930           do j=1,3
16931             do intertyp=1,3
16932              gloc_sc(intertyp,i,icg)=0.0d0
16933             enddo
16934           enddo
16935           enddo
16936           do i=1,nres
16937            do j=1,maxcontsshi
16938            shield_list(j,i)=0
16939           do k=1,3
16940       !C           print *,i,j,k
16941              grad_shield_side(k,j,i)=0.0d0
16942              grad_shield_loc(k,j,i)=0.0d0
16943            enddo
16944            enddo
16945            ishield_list(i)=0
16946           enddo
16947
16948       !
16949       ! Initialize the gradient of local energy terms.
16950       !
16951       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
16952       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
16953       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
16954       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
16955       !      allocate(gel_loc_turn3(nres))
16956       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
16957       !      allocate(gsccor_loc(nres))      !(maxres)
16958
16959           do i=1,4*nres
16960           gloc(i,icg)=0.0D0
16961           enddo
16962           do i=1,nres
16963           gel_loc_loc(i)=0.0d0
16964           gcorr_loc(i)=0.0d0
16965           g_corr5_loc(i)=0.0d0
16966           g_corr6_loc(i)=0.0d0
16967           gel_loc_turn3(i)=0.0d0
16968           gel_loc_turn4(i)=0.0d0
16969           gel_loc_turn6(i)=0.0d0
16970           gsccor_loc(i)=0.0d0
16971           enddo
16972       ! initialize gcart and gxcart
16973       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
16974           do i=0,nres
16975           do j=1,3
16976             gcart(j,i)=0.0d0
16977             gxcart(j,i)=0.0d0
16978           enddo
16979           enddo
16980           return
16981           end subroutine zerograd
16982       !-----------------------------------------------------------------------------
16983           real(kind=8) function fdum()
16984           fdum=0.0D0
16985           return
16986           end function fdum
16987       !-----------------------------------------------------------------------------
16988       ! intcartderiv.F
16989       !-----------------------------------------------------------------------------
16990           subroutine intcartderiv
16991       !      implicit real*8 (a-h,o-z)
16992       !      include 'DIMENSIONS'
16993 #ifdef MPI
16994           include 'mpif.h'
16995 #endif
16996       !      include 'COMMON.SETUP'
16997       !      include 'COMMON.CHAIN'
16998       !      include 'COMMON.VAR'
16999       !      include 'COMMON.GEO'
17000       !      include 'COMMON.INTERACT'
17001       !      include 'COMMON.DERIV'
17002       !      include 'COMMON.IOUNITS'
17003       !      include 'COMMON.LOCAL'
17004       !      include 'COMMON.SCCOR'
17005           real(kind=8) :: pi4,pi34
17006           real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
17007           real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
17008                   dcosomega,dsinomega !(3,3,maxres)
17009           real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
17010
17011           integer :: i,j,k
17012           real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
17013                 fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
17014                 fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
17015                 fac17,coso_inv,fac10,fac11,fac12,fac13,fac14,IERROR
17016           integer :: nres2
17017           nres2=2*nres
17018
17019       !el from module energy-------------
17020       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
17021       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
17022       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
17023
17024       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
17025       !el      allocate(dsintau(3,3,3,0:nres2))
17026       !el      allocate(dtauangle(3,3,3,0:nres2))
17027       !el      allocate(domicron(3,2,2,0:nres2))
17028       !el      allocate(dcosomicron(3,2,2,0:nres2))
17029
17030
17031
17032 #if defined(MPI) && defined(PARINTDER)
17033           if (nfgtasks.gt.1 .and. me.eq.king) &
17034           call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
17035 #endif
17036           pi4 = 0.5d0*pipol
17037           pi34 = 3*pi4
17038
17039       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
17040       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
17041
17042       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
17043           do i=1,nres
17044           do j=1,3
17045             dtheta(j,1,i)=0.0d0
17046             dtheta(j,2,i)=0.0d0
17047             dphi(j,1,i)=0.0d0
17048             dphi(j,2,i)=0.0d0
17049             dphi(j,3,i)=0.0d0
17050             dcosomicron(j,1,1,i)=0.0d0
17051             dcosomicron(j,1,2,i)=0.0d0
17052             dcosomicron(j,2,1,i)=0.0d0
17053             dcosomicron(j,2,2,i)=0.0d0
17054           enddo
17055           enddo
17056       ! Derivatives of theta's
17057 #if defined(MPI) && defined(PARINTDER)
17058       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17059           do i=max0(ithet_start-1,3),ithet_end
17060 #else
17061           do i=3,nres
17062 #endif
17063           cost=dcos(theta(i))
17064           sint=sqrt(1-cost*cost)
17065           do j=1,3
17066             dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
17067             vbld(i-1)
17068             if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
17069             dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
17070             vbld(i)
17071             if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
17072           enddo
17073           enddo
17074 #if defined(MPI) && defined(PARINTDER)
17075       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17076           do i=max0(ithet_start-1,3),ithet_end
17077 #else
17078           do i=3,nres
17079 #endif
17080           if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1).and.molnum(i).ne.5) then
17081           cost1=dcos(omicron(1,i))
17082           sint1=sqrt(1-cost1*cost1)
17083           cost2=dcos(omicron(2,i))
17084           sint2=sqrt(1-cost2*cost2)
17085            do j=1,3
17086       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
17087             dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
17088             cost1*dc_norm(j,i-2))/ &
17089             vbld(i-1)
17090             domicron(j,1,1,i)=-1.0/sint1*dcosomicron(j,1,1,i)
17091             dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
17092             +cost1*(dc_norm(j,i-1+nres)))/ &
17093             vbld(i-1+nres)
17094             domicron(j,1,2,i)=-1.0/sint1*dcosomicron(j,1,2,i)
17095       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
17096       !C Looks messy but better than if in loop
17097             dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
17098             +cost2*dc_norm(j,i-1))/ &
17099             vbld(i)
17100             domicron(j,2,1,i)=-1.0/sint2*dcosomicron(j,2,1,i)
17101             dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
17102              +cost2*(-dc_norm(j,i-1+nres)))/ &
17103             vbld(i-1+nres)
17104       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
17105             domicron(j,2,2,i)=-1.0/sint2*dcosomicron(j,2,2,i)
17106           enddo
17107            endif
17108           enddo
17109       !elwrite(iout,*) "after vbld write"
17110       ! Derivatives of phi:
17111       ! If phi is 0 or 180 degrees, then the formulas
17112       ! have to be derived by power series expansion of the
17113       ! conventional formulas around 0 and 180.
17114 #ifdef PARINTDER
17115           do i=iphi1_start,iphi1_end
17116 #else
17117           do i=4,nres
17118 #endif
17119       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
17120       ! the conventional case
17121           sint=dsin(theta(i))
17122           sint1=dsin(theta(i-1))
17123           sing=dsin(phi(i))
17124           cost=dcos(theta(i))
17125           cost1=dcos(theta(i-1))
17126           cosg=dcos(phi(i))
17127           scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
17128           fac0=1.0d0/(sint1*sint)
17129           fac1=cost*fac0
17130           fac2=cost1*fac0
17131           fac3=cosg*cost1/(sint1*sint1)
17132           fac4=cosg*cost/(sint*sint)
17133       !    Obtaining the gamma derivatives from sine derivative
17134            if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
17135              phi(i).gt.pi34.and.phi(i).le.pi.or. &
17136              phi(i).ge.-pi.and.phi(i).le.-pi34) then
17137            call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17138            call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
17139            call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17140            do j=1,3
17141             ctgt=cost/sint
17142             ctgt1=cost1/sint1
17143             cosg_inv=1.0d0/cosg
17144             if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17145             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17146               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
17147             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
17148             dsinphi(j,2,i)= &
17149               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
17150               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17151             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
17152             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
17153               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17154       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17155             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
17156             endif
17157       ! Bug fixed 3/24/05 (AL)
17158            enddo
17159       !   Obtaining the gamma derivatives from cosine derivative
17160           else
17161              do j=1,3
17162              if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17163              dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17164              dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17165              dc_norm(j,i-3))/vbld(i-2)
17166              dphi(j,1,i)=-1.0/sing*dcosphi(j,1,i)
17167              dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17168              dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17169              dcostheta(j,1,i)
17170              dphi(j,2,i)=-1.0/sing*dcosphi(j,2,i)
17171              dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17172              dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17173              dc_norm(j,i-1))/vbld(i)
17174              dphi(j,3,i)=-1.0/sing*dcosphi(j,3,i)
17175 !#define DEBUG
17176 #ifdef DEBUG
17177              write(iout,*) "just after",dphi(j,3,i),sing,dcosphi(j,3,i)
17178 #endif
17179 !#undef DEBUG
17180              endif
17181            enddo
17182           endif
17183           enddo
17184       !alculate derivative of Tauangle
17185 #ifdef PARINTDER
17186           do i=itau_start,itau_end
17187 #else
17188           do i=3,nres
17189       !elwrite(iout,*) " vecpr",i,nres
17190 #endif
17191            if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17192       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
17193       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
17194       !c dtauangle(j,intertyp,dervityp,residue number)
17195       !c INTERTYP=1 SC...Ca...Ca..Ca
17196       ! the conventional case
17197           sint=dsin(theta(i))
17198           sint1=dsin(omicron(2,i-1))
17199           sing=dsin(tauangle(1,i))
17200           cost=dcos(theta(i))
17201           cost1=dcos(omicron(2,i-1))
17202           cosg=dcos(tauangle(1,i))
17203       !elwrite(iout,*) " vecpr5",i,nres
17204           do j=1,3
17205       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
17206       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
17207           dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17208       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
17209           enddo
17210           scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
17211           fac0=1.0d0/(sint1*sint)
17212           fac1=cost*fac0
17213           fac2=cost1*fac0
17214           fac3=cosg*cost1/(sint1*sint1)
17215           fac4=cosg*cost/(sint*sint)
17216       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
17217       !    Obtaining the gamma derivatives from sine derivative
17218            if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
17219              tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
17220              tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
17221            call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17222            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
17223            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17224           do j=1,3
17225             ctgt=cost/sint
17226             ctgt1=cost1/sint1
17227             cosg_inv=1.0d0/cosg
17228             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17229            -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
17230            *vbld_inv(i-2+nres)
17231             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
17232             dsintau(j,1,2,i)= &
17233               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
17234               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17235       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
17236             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
17237       ! Bug fixed 3/24/05 (AL)
17238             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
17239               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17240       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17241             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
17242            enddo
17243       !   Obtaining the gamma derivatives from cosine derivative
17244           else
17245              do j=1,3
17246              dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17247              dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17248              (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
17249              dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
17250              dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17251              dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17252              dcostheta(j,1,i)
17253              dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
17254              dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17255              dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
17256              dc_norm(j,i-1))/vbld(i)
17257              dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
17258       !         write (iout,*) "else",i
17259            enddo
17260           endif
17261       !        do k=1,3
17262       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
17263       !        enddo
17264           enddo
17265       !C Second case Ca...Ca...Ca...SC
17266 #ifdef PARINTDER
17267           do i=itau_start,itau_end
17268 #else
17269           do i=4,nres
17270 #endif
17271            if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17272             (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
17273       ! the conventional case
17274           sint=dsin(omicron(1,i))
17275           sint1=dsin(theta(i-1))
17276           sing=dsin(tauangle(2,i))
17277           cost=dcos(omicron(1,i))
17278           cost1=dcos(theta(i-1))
17279           cosg=dcos(tauangle(2,i))
17280       !        do j=1,3
17281       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17282       !        enddo
17283           scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
17284           fac0=1.0d0/(sint1*sint)
17285           fac1=cost*fac0
17286           fac2=cost1*fac0
17287           fac3=cosg*cost1/(sint1*sint1)
17288           fac4=cosg*cost/(sint*sint)
17289       !    Obtaining the gamma derivatives from sine derivative
17290            if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
17291              tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
17292              tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
17293            call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
17294            call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
17295            call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17296           do j=1,3
17297             ctgt=cost/sint
17298             ctgt1=cost1/sint1
17299             cosg_inv=1.0d0/cosg
17300             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17301               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
17302       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
17303       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
17304             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
17305             dsintau(j,2,2,i)= &
17306               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
17307               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17308       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
17309       !     & sing*ctgt*domicron(j,1,2,i),
17310       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17311             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
17312       ! Bug fixed 3/24/05 (AL)
17313             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17314              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
17315       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17316             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
17317            enddo
17318       !   Obtaining the gamma derivatives from cosine derivative
17319           else
17320              do j=1,3
17321              dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17322              dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17323              dc_norm(j,i-3))/vbld(i-2)
17324              dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
17325              dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17326              dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17327              dcosomicron(j,1,1,i)
17328              dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
17329              dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17330              dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17331              dc_norm(j,i-1+nres))/vbld(i-1+nres)
17332              dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
17333       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
17334            enddo
17335           endif
17336           enddo
17337
17338       !CC third case SC...Ca...Ca...SC
17339 #ifdef PARINTDER
17340
17341           do i=itau_start,itau_end
17342 #else
17343           do i=3,nres
17344 #endif
17345       ! the conventional case
17346           if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17347           (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17348           sint=dsin(omicron(1,i))
17349           sint1=dsin(omicron(2,i-1))
17350           sing=dsin(tauangle(3,i))
17351           cost=dcos(omicron(1,i))
17352           cost1=dcos(omicron(2,i-1))
17353           cosg=dcos(tauangle(3,i))
17354           do j=1,3
17355           dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17356       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17357           enddo
17358           scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
17359           fac0=1.0d0/(sint1*sint)
17360           fac1=cost*fac0
17361           fac2=cost1*fac0
17362           fac3=cosg*cost1/(sint1*sint1)
17363           fac4=cosg*cost/(sint*sint)
17364       !    Obtaining the gamma derivatives from sine derivative
17365            if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
17366              tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
17367              tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
17368            call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
17369            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
17370            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17371           do j=1,3
17372             ctgt=cost/sint
17373             ctgt1=cost1/sint1
17374             cosg_inv=1.0d0/cosg
17375             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17376               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
17377               *vbld_inv(i-2+nres)
17378             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
17379             dsintau(j,3,2,i)= &
17380               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
17381               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17382             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
17383       ! Bug fixed 3/24/05 (AL)
17384             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17385               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
17386               *vbld_inv(i-1+nres)
17387       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17388             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
17389            enddo
17390       !   Obtaining the gamma derivatives from cosine derivative
17391           else
17392              do j=1,3
17393              dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17394              dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17395              dc_norm2(j,i-2+nres))/vbld(i-2+nres)
17396              dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
17397              dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17398              dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17399              dcosomicron(j,1,1,i)
17400              dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
17401              dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17402              dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
17403              dc_norm(j,i-1+nres))/vbld(i-1+nres)
17404              dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
17405       !          write(iout,*) "else",i
17406            enddo
17407           endif
17408           enddo
17409
17410 #ifdef CRYST_SC
17411       !   Derivatives of side-chain angles alpha and omega
17412 #if defined(MPI) && defined(PARINTDER)
17413           do i=ibond_start,ibond_end
17414 #else
17415           do i=2,nres-1
17416 #endif
17417             if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
17418              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
17419              fac6=fac5/vbld(i)
17420              fac7=fac5*fac5
17421              fac8=fac5/vbld(i+1)
17422              fac9=fac5/vbld(i+nres)
17423              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
17424              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
17425              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
17426              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
17427              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
17428              sina=sqrt(1-cosa*cosa)
17429              sino=dsin(omeg(i))
17430       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
17431              do j=1,3
17432               dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
17433               dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
17434               dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
17435               dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
17436               scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
17437               dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
17438               dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
17439               dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
17440               vbld(i+nres))
17441               dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
17442             enddo
17443       ! obtaining the derivatives of omega from sines
17444             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
17445                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
17446                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
17447                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
17448                dsin(theta(i+1)))
17449                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
17450                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
17451                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
17452                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
17453                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
17454                coso_inv=1.0d0/dcos(omeg(i))
17455                do j=1,3
17456                dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
17457                +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
17458                (sino*dc_norm(j,i-1))/vbld(i)
17459                domega(j,1,i)=coso_inv*dsinomega(j,1,i)
17460                dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
17461                +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
17462                -sino*dc_norm(j,i)/vbld(i+1)
17463                domega(j,2,i)=coso_inv*dsinomega(j,2,i)
17464                dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
17465                fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
17466                vbld(i+nres)
17467                domega(j,3,i)=coso_inv*dsinomega(j,3,i)
17468               enddo
17469              else
17470       !   obtaining the derivatives of omega from cosines
17471              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
17472              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
17473              fac12=fac10*sina
17474              fac13=fac12*fac12
17475              fac14=sina*sina
17476              do j=1,3
17477               dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
17478               dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
17479               (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
17480               fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
17481               domega(j,1,i)=-1/sino*dcosomega(j,1,i)
17482               dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
17483               dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
17484               dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
17485               (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
17486               dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
17487               domega(j,2,i)=-1/sino*dcosomega(j,2,i)
17488               dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
17489               scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
17490               (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
17491               domega(j,3,i)=-1/sino*dcosomega(j,3,i)
17492             enddo
17493             endif
17494            else
17495              do j=1,3
17496              do k=1,3
17497                dalpha(k,j,i)=0.0d0
17498                domega(k,j,i)=0.0d0
17499              enddo
17500              enddo
17501            endif
17502            enddo
17503 #endif
17504 #if defined(MPI) && defined(PARINTDER)
17505           if (nfgtasks.gt.1) then
17506 #ifdef DEBUG
17507       !d      write (iout,*) "Gather dtheta"
17508       !d      call flush(iout)
17509           write (iout,*) "dtheta before gather"
17510           do i=1,nres
17511           write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
17512           enddo
17513 #endif
17514           call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
17515           MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
17516           king,FG_COMM,IERROR)
17517 !#define DEBUG
17518 #ifdef DEBUG
17519       !d      write (iout,*) "Gather dphi"
17520       !d      call flush(iout)
17521           write (iout,*) "dphi before gather"
17522           do i=1,nres
17523           write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
17524           enddo
17525 #endif
17526 !#undef DEBUG
17527           call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
17528           MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
17529           king,FG_COMM,IERROR)
17530       !d      write (iout,*) "Gather dalpha"
17531       !d      call flush(iout)
17532 #ifdef CRYST_SC
17533           call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
17534           MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17535           king,FG_COMM,IERROR)
17536       !d      write (iout,*) "Gather domega"
17537       !d      call flush(iout)
17538           call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
17539           MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17540           king,FG_COMM,IERROR)
17541 #endif
17542           endif
17543 #endif
17544 !#define DEBUG
17545 #ifdef DEBUG
17546           write (iout,*) "dtheta after gather"
17547           do i=1,nres
17548           write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
17549           enddo
17550           write (iout,*) "dphi after gather"
17551           do i=1,nres
17552           write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
17553           enddo
17554           write (iout,*) "dalpha after gather"
17555           do i=1,nres
17556           write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
17557           enddo
17558           write (iout,*) "domega after gather"
17559           do i=1,nres
17560           write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
17561           enddo
17562 #endif
17563 !#undef DEBUG
17564           return
17565           end subroutine intcartderiv
17566       !-----------------------------------------------------------------------------
17567           subroutine checkintcartgrad
17568       !      implicit real*8 (a-h,o-z)
17569       !      include 'DIMENSIONS'
17570 #ifdef MPI
17571           include 'mpif.h'
17572 #endif
17573       !      include 'COMMON.CHAIN'
17574       !      include 'COMMON.VAR'
17575       !      include 'COMMON.GEO'
17576       !      include 'COMMON.INTERACT'
17577       !      include 'COMMON.DERIV'
17578       !      include 'COMMON.IOUNITS'
17579       !      include 'COMMON.SETUP'
17580           real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
17581           real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
17582           real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
17583           real(kind=8),dimension(3) :: dc_norm_s
17584           real(kind=8) :: aincr=1.0d-5
17585           integer :: i,j
17586           real(kind=8) :: dcji
17587           do i=1,nres
17588           phi_s(i)=phi(i)
17589           theta_s(i)=theta(i)
17590           alph_s(i)=alph(i)
17591           omeg_s(i)=omeg(i)
17592           enddo
17593       ! Check theta gradient
17594           write (iout,*) &
17595            "Analytical (upper) and numerical (lower) gradient of theta"
17596           write (iout,*)
17597           do i=3,nres
17598           do j=1,3
17599             dcji=dc(j,i-2)
17600             dc(j,i-2)=dcji+aincr
17601             call chainbuild_cart
17602             call int_from_cart1(.false.)
17603         dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
17604         dc(j,i-2)=dcji
17605         dcji=dc(j,i-1)
17606         dc(j,i-1)=dc(j,i-1)+aincr
17607         call chainbuild_cart
17608         dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
17609         dc(j,i-1)=dcji
17610       enddo
17611 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
17612 !el          (dtheta(j,2,i),j=1,3)
17613 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
17614 !el          (dthetanum(j,2,i),j=1,3)
17615 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
17616 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
17617 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
17618 !el        write (iout,*)
17619       enddo
17620 ! Check gamma gradient
17621       write (iout,*) &
17622        "Analytical (upper) and numerical (lower) gradient of gamma"
17623       do i=4,nres
17624       do j=1,3
17625         dcji=dc(j,i-3)
17626         dc(j,i-3)=dcji+aincr
17627         call chainbuild_cart
17628         dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
17629             dc(j,i-3)=dcji
17630         dcji=dc(j,i-2)
17631         dc(j,i-2)=dcji+aincr
17632         call chainbuild_cart
17633         dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
17634         dc(j,i-2)=dcji
17635         dcji=dc(j,i-1)
17636         dc(j,i-1)=dc(j,i-1)+aincr
17637         call chainbuild_cart
17638         dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
17639         dc(j,i-1)=dcji
17640       enddo
17641 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
17642 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
17643 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
17644 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
17645 !el        write (iout,'(5x,3(3f10.5,5x))') &
17646 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
17647 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
17648 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
17649 !el        write (iout,*)
17650       enddo
17651 ! Check alpha gradient
17652       write (iout,*) &
17653        "Analytical (upper) and numerical (lower) gradient of alpha"
17654       do i=2,nres-1
17655        if(itype(i,1).ne.10) then
17656              do j=1,3
17657               dcji=dc(j,i-1)
17658                dc(j,i-1)=dcji+aincr
17659             call chainbuild_cart
17660             dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
17661              /aincr
17662               dc(j,i-1)=dcji
17663             dcji=dc(j,i)
17664             dc(j,i)=dcji+aincr
17665             call chainbuild_cart
17666             dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
17667              /aincr
17668             dc(j,i)=dcji
17669             dcji=dc(j,i+nres)
17670             dc(j,i+nres)=dc(j,i+nres)+aincr
17671             call chainbuild_cart
17672             dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
17673              /aincr
17674            dc(j,i+nres)=dcji
17675           enddo
17676         endif
17677 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
17678 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
17679 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
17680 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
17681 !el        write (iout,'(5x,3(3f10.5,5x))') &
17682 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
17683 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
17684 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
17685 !el        write (iout,*)
17686       enddo
17687 !     Check omega gradient
17688       write (iout,*) &
17689        "Analytical (upper) and numerical (lower) gradient of omega"
17690       do i=2,nres-1
17691        if(itype(i,1).ne.10) then
17692              do j=1,3
17693               dcji=dc(j,i-1)
17694                dc(j,i-1)=dcji+aincr
17695             call chainbuild_cart
17696             domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
17697              /aincr
17698               dc(j,i-1)=dcji
17699             dcji=dc(j,i)
17700             dc(j,i)=dcji+aincr
17701             call chainbuild_cart
17702             domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
17703              /aincr
17704             dc(j,i)=dcji
17705             dcji=dc(j,i+nres)
17706             dc(j,i+nres)=dc(j,i+nres)+aincr
17707             call chainbuild_cart
17708             domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
17709              /aincr
17710            dc(j,i+nres)=dcji
17711           enddo
17712         endif
17713 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
17714 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
17715 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
17716 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
17717 !el        write (iout,'(5x,3(3f10.5,5x))') &
17718 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
17719 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
17720 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
17721 !el        write (iout,*)
17722       enddo
17723       return
17724       end subroutine checkintcartgrad
17725 !-----------------------------------------------------------------------------
17726 ! q_measure.F
17727 !-----------------------------------------------------------------------------
17728       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
17729 !      implicit real*8 (a-h,o-z)
17730 !      include 'DIMENSIONS'
17731 !      include 'COMMON.IOUNITS'
17732 !      include 'COMMON.CHAIN'
17733 !      include 'COMMON.INTERACT'
17734 !      include 'COMMON.VAR'
17735       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
17736       integer :: kkk,nsep=3
17737       real(kind=8) :: qm      !dist,
17738       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
17739       logical :: lprn=.false.
17740       logical :: flag
17741 !      real(kind=8) :: sigm,x
17742
17743 !el      sigm(x)=0.25d0*x     ! local function
17744       qqmax=1.0d10
17745       do kkk=1,nperm
17746       qq = 0.0d0
17747       nl=0
17748        if(flag) then
17749       do il=seg1+nsep,seg2
17750         do jl=seg1,il-nsep
17751           nl=nl+1
17752           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
17753                    (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
17754                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17755           dij=dist(il,jl)
17756           qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17757           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17758             nl=nl+1
17759             d0ijCM=dsqrt( &
17760                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17761                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17762                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17763             dijCM=dist(il+nres,jl+nres)
17764             qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17765           endif
17766           qq = qq+qqij+qqijCM
17767         enddo
17768       enddo
17769       qq = qq/nl
17770       else
17771       do il=seg1,seg2
17772       if((seg3-il).lt.3) then
17773            secseg=il+3
17774       else
17775            secseg=seg3
17776       endif
17777         do jl=secseg,seg4
17778           nl=nl+1
17779           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17780                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17781                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17782           dij=dist(il,jl)
17783           qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17784           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17785             nl=nl+1
17786             d0ijCM=dsqrt( &
17787                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17788                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17789                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17790             dijCM=dist(il+nres,jl+nres)
17791             qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17792           endif
17793           qq = qq+qqij+qqijCM
17794         enddo
17795       enddo
17796       qq = qq/nl
17797       endif
17798       if (qqmax.le.qq) qqmax=qq
17799       enddo
17800       qwolynes=1.0d0-qqmax
17801       return
17802       end function qwolynes
17803 !-----------------------------------------------------------------------------
17804       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
17805 !      implicit real*8 (a-h,o-z)
17806 !      include 'DIMENSIONS'
17807 !      include 'COMMON.IOUNITS'
17808 !      include 'COMMON.CHAIN'
17809 !      include 'COMMON.INTERACT'
17810 !      include 'COMMON.VAR'
17811 !      include 'COMMON.MD'
17812       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
17813       integer :: nsep=3, kkk
17814 !el      real(kind=8) :: dist
17815       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
17816       logical :: lprn=.false.
17817       logical :: flag
17818       real(kind=8) :: sim,dd0,fac,ddqij
17819 !el      sigm(x)=0.25d0*x           ! local function
17820       do kkk=1,nperm
17821       do i=0,nres
17822       do j=1,3
17823         dqwol(j,i)=0.0d0
17824         dxqwol(j,i)=0.0d0
17825       enddo
17826       enddo
17827       nl=0
17828        if(flag) then
17829       do il=seg1+nsep,seg2
17830         do jl=seg1,il-nsep
17831           nl=nl+1
17832           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17833                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17834                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17835           dij=dist(il,jl)
17836           sim = 1.0d0/sigm(d0ij)
17837           sim = sim*sim
17838           dd0 = dij-d0ij
17839           fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17840         do k=1,3
17841             ddqij = (c(k,il)-c(k,jl))*fac
17842             dqwol(k,il)=dqwol(k,il)+ddqij
17843             dqwol(k,jl)=dqwol(k,jl)-ddqij
17844           enddo
17845
17846           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17847             nl=nl+1
17848             d0ijCM=dsqrt( &
17849                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17850                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17851                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17852             dijCM=dist(il+nres,jl+nres)
17853             sim = 1.0d0/sigm(d0ijCM)
17854             sim = sim*sim
17855             dd0=dijCM-d0ijCM
17856             fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17857             do k=1,3
17858             ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17859             dxqwol(k,il)=dxqwol(k,il)+ddqij
17860             dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17861             enddo
17862           endif
17863         enddo
17864       enddo
17865        else
17866       do il=seg1,seg2
17867       if((seg3-il).lt.3) then
17868            secseg=il+3
17869       else
17870            secseg=seg3
17871       endif
17872         do jl=secseg,seg4
17873           nl=nl+1
17874           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17875                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17876                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17877           dij=dist(il,jl)
17878           sim = 1.0d0/sigm(d0ij)
17879           sim = sim*sim
17880           dd0 = dij-d0ij
17881           fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17882           do k=1,3
17883             ddqij = (c(k,il)-c(k,jl))*fac
17884             dqwol(k,il)=dqwol(k,il)+ddqij
17885             dqwol(k,jl)=dqwol(k,jl)-ddqij
17886           enddo
17887           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17888             nl=nl+1
17889             d0ijCM=dsqrt( &
17890                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17891                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17892                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17893             dijCM=dist(il+nres,jl+nres)
17894             sim = 1.0d0/sigm(d0ijCM)
17895             sim=sim*sim
17896             dd0 = dijCM-d0ijCM
17897             fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17898             do k=1,3
17899              ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17900              dxqwol(k,il)=dxqwol(k,il)+ddqij
17901              dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17902             enddo
17903           endif
17904         enddo
17905       enddo
17906       endif
17907       enddo
17908        do i=0,nres
17909        do j=1,3
17910          dqwol(j,i)=dqwol(j,i)/nl
17911          dxqwol(j,i)=dxqwol(j,i)/nl
17912        enddo
17913        enddo
17914       return
17915       end subroutine qwolynes_prim
17916 !-----------------------------------------------------------------------------
17917       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
17918 !      implicit real*8 (a-h,o-z)
17919 !      include 'DIMENSIONS'
17920 !      include 'COMMON.IOUNITS'
17921 !      include 'COMMON.CHAIN'
17922 !      include 'COMMON.INTERACT'
17923 !      include 'COMMON.VAR'
17924       integer :: seg1,seg2,seg3,seg4
17925       logical :: flag
17926       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
17927       real(kind=8),dimension(3,0:2*nres) :: cdummy
17928       real(kind=8) :: q1,q2
17929       real(kind=8) :: delta=1.0d-10
17930       integer :: i,j
17931
17932       do i=0,nres
17933       do j=1,3
17934         q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17935         cdummy(j,i)=c(j,i)
17936         c(j,i)=c(j,i)+delta
17937         q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17938         qwolan(j,i)=(q2-q1)/delta
17939         c(j,i)=cdummy(j,i)
17940       enddo
17941       enddo
17942       do i=0,nres
17943       do j=1,3
17944         q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17945         cdummy(j,i+nres)=c(j,i+nres)
17946         c(j,i+nres)=c(j,i+nres)+delta
17947         q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17948         qwolxan(j,i)=(q2-q1)/delta
17949         c(j,i+nres)=cdummy(j,i+nres)
17950       enddo
17951       enddo
17952 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
17953 !      do i=0,nct
17954 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
17955 !      enddo
17956 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
17957 !      do i=0,nct
17958 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
17959 !      enddo
17960       return
17961       end subroutine qwol_num
17962 !-----------------------------------------------------------------------------
17963       subroutine EconstrQ
17964 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
17965 !      implicit real*8 (a-h,o-z)
17966 !      include 'DIMENSIONS'
17967 !      include 'COMMON.CONTROL'
17968 !      include 'COMMON.VAR'
17969 !      include 'COMMON.MD'
17970       use MD_data
17971 !#ifndef LANG0
17972 !      include 'COMMON.LANGEVIN'
17973 !#else
17974 !      include 'COMMON.LANGEVIN.lang0'
17975 !#endif
17976 !      include 'COMMON.CHAIN'
17977 !      include 'COMMON.DERIV'
17978 !      include 'COMMON.GEO'
17979 !      include 'COMMON.LOCAL'
17980 !      include 'COMMON.INTERACT'
17981 !      include 'COMMON.IOUNITS'
17982 !      include 'COMMON.NAMES'
17983 !      include 'COMMON.TIME1'
17984       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
17985       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
17986                duconst,duxconst
17987       integer :: kstart,kend,lstart,lend,idummy
17988       real(kind=8) :: delta=1.0d-7
17989       integer :: i,j,k,ii
17990       do i=0,nres
17991        do j=1,3
17992           duconst(j,i)=0.0d0
17993           dudconst(j,i)=0.0d0
17994           duxconst(j,i)=0.0d0
17995           dudxconst(j,i)=0.0d0
17996        enddo
17997       enddo
17998       Uconst=0.0d0
17999       do i=1,nfrag
18000        qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18001          idummy,idummy)
18002        Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
18003 ! Calculating the derivatives of Constraint energy with respect to Q
18004        Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
18005          qinfrag(i,iset))
18006 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
18007 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
18008 !         hmnum=(hm2-hm1)/delta
18009 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
18010 !     &   qinfrag(i,iset))
18011 !         write(iout,*) "harmonicnum frag", hmnum
18012 ! Calculating the derivatives of Q with respect to cartesian coordinates
18013        call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18014         idummy,idummy)
18015 !         write(iout,*) "dqwol "
18016 !         do ii=1,nres
18017 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18018 !         enddo
18019 !         write(iout,*) "dxqwol "
18020 !         do ii=1,nres
18021 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18022 !         enddo
18023 ! Calculating numerical gradients of dU/dQi and dQi/dxi
18024 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
18025 !     &  ,idummy,idummy)
18026 !  The gradients of Uconst in Cs
18027        do ii=0,nres
18028           do j=1,3
18029              duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
18030              dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
18031           enddo
18032        enddo
18033       enddo
18034       do i=1,npair
18035        kstart=ifrag(1,ipair(1,i,iset),iset)
18036        kend=ifrag(2,ipair(1,i,iset),iset)
18037        lstart=ifrag(1,ipair(2,i,iset),iset)
18038        lend=ifrag(2,ipair(2,i,iset),iset)
18039        qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
18040        Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
18041 !  Calculating dU/dQ
18042        Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
18043 !         hm1=harmonic(qpair(i),qinpair(i,iset))
18044 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
18045 !         hmnum=(hm2-hm1)/delta
18046 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
18047 !     &   qinpair(i,iset))
18048 !         write(iout,*) "harmonicnum pair ", hmnum
18049 ! Calculating dQ/dXi
18050        call qwolynes_prim(kstart,kend,.false.,&
18051         lstart,lend)
18052 !         write(iout,*) "dqwol "
18053 !         do ii=1,nres
18054 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18055 !         enddo
18056 !         write(iout,*) "dxqwol "
18057 !         do ii=1,nres
18058 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18059 !        enddo
18060 ! Calculating numerical gradients
18061 !        call qwol_num(kstart,kend,.false.
18062 !     &  ,lstart,lend)
18063 ! The gradients of Uconst in Cs
18064        do ii=0,nres
18065           do j=1,3
18066              duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
18067              dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
18068           enddo
18069        enddo
18070       enddo
18071 !      write(iout,*) "Uconst inside subroutine ", Uconst
18072 ! Transforming the gradients from Cs to dCs for the backbone
18073       do i=0,nres
18074        do j=i+1,nres
18075          do k=1,3
18076            dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
18077          enddo
18078        enddo
18079       enddo
18080 !  Transforming the gradients from Cs to dCs for the side chains
18081       do i=1,nres
18082        do j=1,3
18083          dudxconst(j,i)=duxconst(j,i)
18084        enddo
18085       enddo
18086 !      write(iout,*) "dU/ddc backbone "
18087 !       do ii=0,nres
18088 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
18089 !      enddo
18090 !      write(iout,*) "dU/ddX side chain "
18091 !      do ii=1,nres
18092 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
18093 !      enddo
18094 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
18095 !      call dEconstrQ_num
18096       return
18097       end subroutine EconstrQ
18098 !-----------------------------------------------------------------------------
18099       subroutine dEconstrQ_num
18100 ! Calculating numerical dUconst/ddc and dUconst/ddx
18101 !      implicit real*8 (a-h,o-z)
18102 !      include 'DIMENSIONS'
18103 !      include 'COMMON.CONTROL'
18104 !      include 'COMMON.VAR'
18105 !      include 'COMMON.MD'
18106       use MD_data
18107 !#ifndef LANG0
18108 !      include 'COMMON.LANGEVIN'
18109 !#else
18110 !      include 'COMMON.LANGEVIN.lang0'
18111 !#endif
18112 !      include 'COMMON.CHAIN'
18113 !      include 'COMMON.DERIV'
18114 !      include 'COMMON.GEO'
18115 !      include 'COMMON.LOCAL'
18116 !      include 'COMMON.INTERACT'
18117 !      include 'COMMON.IOUNITS'
18118 !      include 'COMMON.NAMES'
18119 !      include 'COMMON.TIME1'
18120       real(kind=8) :: uzap1,uzap2
18121       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
18122       integer :: kstart,kend,lstart,lend,idummy
18123       real(kind=8) :: delta=1.0d-7
18124 !el local variables
18125       integer :: i,ii,j
18126 !     real(kind=8) ::
18127 !     For the backbone
18128       do i=0,nres-1
18129        do j=1,3
18130           dUcartan(j,i)=0.0d0
18131           cdummy(j,i)=dc(j,i)
18132           dc(j,i)=dc(j,i)+delta
18133           call chainbuild_cart
18134         uzap2=0.0d0
18135           do ii=1,nfrag
18136            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18137             idummy,idummy)
18138              uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18139             qinfrag(ii,iset))
18140           enddo
18141           do ii=1,npair
18142              kstart=ifrag(1,ipair(1,ii,iset),iset)
18143              kend=ifrag(2,ipair(1,ii,iset),iset)
18144              lstart=ifrag(1,ipair(2,ii,iset),iset)
18145              lend=ifrag(2,ipair(2,ii,iset),iset)
18146              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18147              uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18148              qinpair(ii,iset))
18149           enddo
18150           dc(j,i)=cdummy(j,i)
18151           call chainbuild_cart
18152           uzap1=0.0d0
18153            do ii=1,nfrag
18154            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18155             idummy,idummy)
18156              uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18157             qinfrag(ii,iset))
18158           enddo
18159           do ii=1,npair
18160              kstart=ifrag(1,ipair(1,ii,iset),iset)
18161              kend=ifrag(2,ipair(1,ii,iset),iset)
18162              lstart=ifrag(1,ipair(2,ii,iset),iset)
18163              lend=ifrag(2,ipair(2,ii,iset),iset)
18164              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18165              uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18166             qinpair(ii,iset))
18167           enddo
18168           ducartan(j,i)=(uzap2-uzap1)/(delta)
18169        enddo
18170       enddo
18171 ! Calculating numerical gradients for dU/ddx
18172       do i=0,nres-1
18173        duxcartan(j,i)=0.0d0
18174        do j=1,3
18175           cdummy(j,i)=dc(j,i+nres)
18176           dc(j,i+nres)=dc(j,i+nres)+delta
18177           call chainbuild_cart
18178         uzap2=0.0d0
18179           do ii=1,nfrag
18180            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18181             idummy,idummy)
18182              uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18183             qinfrag(ii,iset))
18184           enddo
18185           do ii=1,npair
18186              kstart=ifrag(1,ipair(1,ii,iset),iset)
18187              kend=ifrag(2,ipair(1,ii,iset),iset)
18188              lstart=ifrag(1,ipair(2,ii,iset),iset)
18189              lend=ifrag(2,ipair(2,ii,iset),iset)
18190              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18191              uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18192             qinpair(ii,iset))
18193           enddo
18194           dc(j,i+nres)=cdummy(j,i)
18195           call chainbuild_cart
18196           uzap1=0.0d0
18197            do ii=1,nfrag
18198              qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
18199             ifrag(2,ii,iset),.true.,idummy,idummy)
18200              uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18201             qinfrag(ii,iset))
18202           enddo
18203           do ii=1,npair
18204              kstart=ifrag(1,ipair(1,ii,iset),iset)
18205              kend=ifrag(2,ipair(1,ii,iset),iset)
18206              lstart=ifrag(1,ipair(2,ii,iset),iset)
18207              lend=ifrag(2,ipair(2,ii,iset),iset)
18208              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18209              uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18210             qinpair(ii,iset))
18211           enddo
18212           duxcartan(j,i)=(uzap2-uzap1)/(delta)
18213        enddo
18214       enddo
18215       write(iout,*) "Numerical dUconst/ddc backbone "
18216       do ii=0,nres
18217       write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
18218       enddo
18219 !      write(iout,*) "Numerical dUconst/ddx side-chain "
18220 !      do ii=1,nres
18221 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
18222 !      enddo
18223       return
18224       end subroutine dEconstrQ_num
18225 !-----------------------------------------------------------------------------
18226 ! ssMD.F
18227 !-----------------------------------------------------------------------------
18228       subroutine check_energies
18229
18230 !      use random, only: ran_number
18231
18232 !      implicit none
18233 !     Includes
18234 !      include 'DIMENSIONS'
18235 !      include 'COMMON.CHAIN'
18236 !      include 'COMMON.VAR'
18237 !      include 'COMMON.IOUNITS'
18238 !      include 'COMMON.SBRIDGE'
18239 !      include 'COMMON.LOCAL'
18240 !      include 'COMMON.GEO'
18241
18242 !     External functions
18243 !EL      double precision ran_number
18244 !EL      external ran_number
18245
18246 !     Local variables
18247       integer :: i,j,k,l,lmax,p,pmax
18248       real(kind=8) :: rmin,rmax
18249       real(kind=8) :: eij
18250
18251       real(kind=8) :: d
18252       real(kind=8) :: wi,rij,tj,pj
18253 !      return
18254
18255       i=5
18256       j=14
18257
18258       d=dsc(1)
18259       rmin=2.0D0
18260       rmax=12.0D0
18261
18262       lmax=10000
18263       pmax=1
18264
18265       do k=1,3
18266       c(k,i)=0.0D0
18267       c(k,j)=0.0D0
18268       c(k,nres+i)=0.0D0
18269       c(k,nres+j)=0.0D0
18270       enddo
18271
18272       do l=1,lmax
18273
18274 !t        wi=ran_number(0.0D0,pi)
18275 !        wi=ran_number(0.0D0,pi/6.0D0)
18276 !        wi=0.0D0
18277 !t        tj=ran_number(0.0D0,pi)
18278 !t        pj=ran_number(0.0D0,pi)
18279 !        pj=ran_number(0.0D0,pi/6.0D0)
18280 !        pj=0.0D0
18281
18282       do p=1,pmax
18283 !t           rij=ran_number(rmin,rmax)
18284
18285          c(1,j)=d*sin(pj)*cos(tj)
18286          c(2,j)=d*sin(pj)*sin(tj)
18287          c(3,j)=d*cos(pj)
18288
18289          c(3,nres+i)=-rij
18290
18291          c(1,i)=d*sin(wi)
18292          c(3,i)=-rij-d*cos(wi)
18293
18294          do k=1,3
18295             dc(k,nres+i)=c(k,nres+i)-c(k,i)
18296             dc_norm(k,nres+i)=dc(k,nres+i)/d
18297             dc(k,nres+j)=c(k,nres+j)-c(k,j)
18298             dc_norm(k,nres+j)=dc(k,nres+j)/d
18299          enddo
18300
18301          call dyn_ssbond_ene(i,j,eij)
18302       enddo
18303       enddo
18304       call exit(1)
18305       return
18306       end subroutine check_energies
18307 !-----------------------------------------------------------------------------
18308       subroutine dyn_ssbond_ene(resi,resj,eij)
18309 !      implicit none
18310 !      Includes
18311       use calc_data
18312       use comm_sschecks
18313 !      include 'DIMENSIONS'
18314 !      include 'COMMON.SBRIDGE'
18315 !      include 'COMMON.CHAIN'
18316 !      include 'COMMON.DERIV'
18317 !      include 'COMMON.LOCAL'
18318 !      include 'COMMON.INTERACT'
18319 !      include 'COMMON.VAR'
18320 !      include 'COMMON.IOUNITS'
18321 !      include 'COMMON.CALC'
18322 #ifndef CLUST
18323 #ifndef WHAM
18324        use MD_data
18325 !      include 'COMMON.MD'
18326 !      use MD, only: totT,t_bath
18327 #endif
18328 #endif
18329 !     External functions
18330 !EL      double precision h_base
18331 !EL      external h_base
18332
18333 !     Input arguments
18334       integer :: resi,resj
18335
18336 !     Output arguments
18337       real(kind=8) :: eij
18338
18339 !     Local variables
18340       logical :: havebond
18341       integer itypi,itypj
18342       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
18343       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
18344       real(kind=8),dimension(3) :: dcosom1,dcosom2
18345       real(kind=8) :: ed
18346       real(kind=8) :: pom1,pom2
18347       real(kind=8) :: ljA,ljB,ljXs
18348       real(kind=8),dimension(1:3) :: d_ljB
18349       real(kind=8) :: ssA,ssB,ssC,ssXs
18350       real(kind=8) :: ssxm,ljxm,ssm,ljm
18351       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
18352       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
18353       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
18354 !-------FIRST METHOD
18355       real(kind=8) :: xm
18356       real(kind=8),dimension(1:3) :: d_xm
18357 !-------END FIRST METHOD
18358 !-------SECOND METHOD
18359 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
18360 !-------END SECOND METHOD
18361
18362 !-------TESTING CODE
18363 !el      logical :: checkstop,transgrad
18364 !el      common /sschecks/ checkstop,transgrad
18365
18366       integer :: icheck,nicheck,jcheck,njcheck
18367       real(kind=8),dimension(-1:1) :: echeck
18368       real(kind=8) :: deps,ssx0,ljx0
18369 !-------END TESTING CODE
18370
18371       eij=0.0d0
18372       i=resi
18373       j=resj
18374
18375 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
18376 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
18377
18378       itypi=itype(i,1)
18379       dxi=dc_norm(1,nres+i)
18380       dyi=dc_norm(2,nres+i)
18381       dzi=dc_norm(3,nres+i)
18382       dsci_inv=vbld_inv(i+nres)
18383
18384       itypj=itype(j,1)
18385       xj=c(1,nres+j)-c(1,nres+i)
18386       yj=c(2,nres+j)-c(2,nres+i)
18387       zj=c(3,nres+j)-c(3,nres+i)
18388       dxj=dc_norm(1,nres+j)
18389       dyj=dc_norm(2,nres+j)
18390       dzj=dc_norm(3,nres+j)
18391       dscj_inv=vbld_inv(j+nres)
18392
18393       chi1=chi(itypi,itypj)
18394       chi2=chi(itypj,itypi)
18395       chi12=chi1*chi2
18396       chip1=chip(itypi)
18397       chip2=chip(itypj)
18398       chip12=chip1*chip2
18399       alf1=alp(itypi)
18400       alf2=alp(itypj)
18401       alf12=0.5D0*(alf1+alf2)
18402
18403       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
18404       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18405 !     The following are set in sc_angular
18406 !      erij(1)=xj*rij
18407 !      erij(2)=yj*rij
18408 !      erij(3)=zj*rij
18409 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
18410 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
18411 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
18412       call sc_angular
18413       rij=1.0D0/rij  ! Reset this so it makes sense
18414
18415       sig0ij=sigma(itypi,itypj)
18416       sig=sig0ij*dsqrt(1.0D0/sigsq)
18417
18418       ljXs=sig-sig0ij
18419       ljA=eps1*eps2rt**2*eps3rt**2
18420       ljB=ljA*bb_aq(itypi,itypj)
18421       ljA=ljA*aa_aq(itypi,itypj)
18422       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
18423
18424       ssXs=d0cm
18425       deltat1=1.0d0-om1
18426       deltat2=1.0d0+om2
18427       deltat12=om2-om1+2.0d0
18428       cosphi=om12-om1*om2
18429       ssA=akcm
18430       ssB=akct*deltat12
18431       ssC=ss_depth &
18432          +akth*(deltat1*deltat1+deltat2*deltat2) &
18433          +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
18434       ssxm=ssXs-0.5D0*ssB/ssA
18435
18436 !-------TESTING CODE
18437 !$$$c     Some extra output
18438 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
18439 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
18440 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
18441 !$$$      if (ssx0.gt.0.0d0) then
18442 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
18443 !$$$      else
18444 !$$$        ssx0=ssxm
18445 !$$$      endif
18446 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
18447 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
18448 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
18449 !$$$      return
18450 !-------END TESTING CODE
18451
18452 !-------TESTING CODE
18453 !     Stop and plot energy and derivative as a function of distance
18454       if (checkstop) then
18455       ssm=ssC-0.25D0*ssB*ssB/ssA
18456       ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18457       if (ssm.lt.ljm .and. &
18458            dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
18459         nicheck=1000
18460         njcheck=1
18461         deps=0.5d-7
18462       else
18463         checkstop=.false.
18464       endif
18465       endif
18466       if (.not.checkstop) then
18467       nicheck=0
18468       njcheck=-1
18469       endif
18470
18471       do icheck=0,nicheck
18472       do jcheck=-1,njcheck
18473       if (checkstop) rij=(ssxm-1.0d0)+ &
18474            ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
18475 !-------END TESTING CODE
18476
18477       if (rij.gt.ljxm) then
18478       havebond=.false.
18479       ljd=rij-ljXs
18480       fac=(1.0D0/ljd)**expon
18481       e1=fac*fac*aa_aq(itypi,itypj)
18482       e2=fac*bb_aq(itypi,itypj)
18483       eij=eps1*eps2rt*eps3rt*(e1+e2)
18484       eps2der=eij*eps3rt
18485       eps3der=eij*eps2rt
18486       eij=eij*eps2rt*eps3rt
18487
18488       sigder=-sig/sigsq
18489       e1=e1*eps1*eps2rt**2*eps3rt**2
18490       ed=-expon*(e1+eij)/ljd
18491       sigder=ed*sigder
18492       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
18493       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
18494       eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
18495            -2.0D0*alf12*eps3der+sigder*sigsq_om12
18496       else if (rij.lt.ssxm) then
18497       havebond=.true.
18498       ssd=rij-ssXs
18499       eij=ssA*ssd*ssd+ssB*ssd+ssC
18500
18501       ed=2*akcm*ssd+akct*deltat12
18502       pom1=akct*ssd
18503       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
18504       eom1=-2*akth*deltat1-pom1-om2*pom2
18505       eom2= 2*akth*deltat2+pom1-om1*pom2
18506       eom12=pom2
18507       else
18508       omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
18509
18510       d_ssxm(1)=0.5D0*akct/ssA
18511       d_ssxm(2)=-d_ssxm(1)
18512       d_ssxm(3)=0.0D0
18513
18514       d_ljxm(1)=sig0ij/sqrt(sigsq**3)
18515       d_ljxm(2)=d_ljxm(1)*sigsq_om2
18516       d_ljxm(3)=d_ljxm(1)*sigsq_om12
18517       d_ljxm(1)=d_ljxm(1)*sigsq_om1
18518
18519 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18520       xm=0.5d0*(ssxm+ljxm)
18521       do k=1,3
18522         d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
18523       enddo
18524       if (rij.lt.xm) then
18525         havebond=.true.
18526         ssm=ssC-0.25D0*ssB*ssB/ssA
18527         d_ssm(1)=0.5D0*akct*ssB/ssA
18528         d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18529         d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18530         d_ssm(3)=omega
18531         f1=(rij-xm)/(ssxm-xm)
18532         f2=(rij-ssxm)/(xm-ssxm)
18533         h1=h_base(f1,hd1)
18534         h2=h_base(f2,hd2)
18535         eij=ssm*h1+Ht*h2
18536         delta_inv=1.0d0/(xm-ssxm)
18537         deltasq_inv=delta_inv*delta_inv
18538         fac=ssm*hd1-Ht*hd2
18539         fac1=deltasq_inv*fac*(xm-rij)
18540         fac2=deltasq_inv*fac*(rij-ssxm)
18541         ed=delta_inv*(Ht*hd2-ssm*hd1)
18542         eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
18543         eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
18544         eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
18545       else
18546         havebond=.false.
18547         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18548         d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
18549         d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
18550         d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
18551              alf12/eps3rt)
18552         d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
18553         f1=(rij-ljxm)/(xm-ljxm)
18554         f2=(rij-xm)/(ljxm-xm)
18555         h1=h_base(f1,hd1)
18556         h2=h_base(f2,hd2)
18557         eij=Ht*h1+ljm*h2
18558         delta_inv=1.0d0/(ljxm-xm)
18559         deltasq_inv=delta_inv*delta_inv
18560         fac=Ht*hd1-ljm*hd2
18561         fac1=deltasq_inv*fac*(ljxm-rij)
18562         fac2=deltasq_inv*fac*(rij-xm)
18563         ed=delta_inv*(ljm*hd2-Ht*hd1)
18564         eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
18565         eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
18566         eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
18567       endif
18568 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18569
18570 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18571 !$$$        ssd=rij-ssXs
18572 !$$$        ljd=rij-ljXs
18573 !$$$        fac1=rij-ljxm
18574 !$$$        fac2=rij-ssxm
18575 !$$$
18576 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
18577 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
18578 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
18579 !$$$
18580 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
18581 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
18582 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18583 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18584 !$$$        d_ssm(3)=omega
18585 !$$$
18586 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
18587 !$$$        do k=1,3
18588 !$$$          d_ljm(k)=ljm*d_ljB(k)
18589 !$$$        enddo
18590 !$$$        ljm=ljm*ljB
18591 !$$$
18592 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
18593 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
18594 !$$$        d_ss(2)=akct*ssd
18595 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
18596 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
18597 !$$$        d_ss(3)=omega
18598 !$$$
18599 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
18600 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
18601 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
18602 !$$$        do k=1,3
18603 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
18604 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
18605 !$$$        enddo
18606 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
18607 !$$$
18608 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
18609 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
18610 !$$$        h1=h_base(f1,hd1)
18611 !$$$        h2=h_base(f2,hd2)
18612 !$$$        eij=ss*h1+ljf*h2
18613 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
18614 !$$$        deltasq_inv=delta_inv*delta_inv
18615 !$$$        fac=ljf*hd2-ss*hd1
18616 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
18617 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
18618 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
18619 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
18620 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
18621 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
18622 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
18623 !$$$
18624 !$$$        havebond=.false.
18625 !$$$        if (ed.gt.0.0d0) havebond=.true.
18626 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18627
18628       endif
18629
18630       if (havebond) then
18631 !#ifndef CLUST
18632 !#ifndef WHAM
18633 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
18634 !          write(iout,'(a15,f12.2,f8.1,2i5)')
18635 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
18636 !        endif
18637 !#endif
18638 !#endif
18639       dyn_ssbond_ij(i,j)=eij
18640       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
18641       dyn_ssbond_ij(i,j)=1.0d300
18642 !#ifndef CLUST
18643 !#ifndef WHAM
18644 !        write(iout,'(a15,f12.2,f8.1,2i5)')
18645 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
18646 !#endif
18647 !#endif
18648       endif
18649
18650 !-------TESTING CODE
18651 !el      if (checkstop) then
18652       if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
18653            "CHECKSTOP",rij,eij,ed
18654       echeck(jcheck)=eij
18655 !el      endif
18656       enddo
18657       if (checkstop) then
18658       write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
18659       endif
18660       enddo
18661       if (checkstop) then
18662       transgrad=.true.
18663       checkstop=.false.
18664       endif
18665 !-------END TESTING CODE
18666
18667       do k=1,3
18668       dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
18669       dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
18670       enddo
18671       do k=1,3
18672       gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
18673       enddo
18674       do k=1,3
18675       gvdwx(k,i)=gvdwx(k,i)-gg(k) &
18676            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
18677            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
18678       gvdwx(k,j)=gvdwx(k,j)+gg(k) &
18679            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
18680            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
18681       enddo
18682 !grad      do k=i,j-1
18683 !grad        do l=1,3
18684 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
18685 !grad        enddo
18686 !grad      enddo
18687
18688       do l=1,3
18689       gvdwc(l,i)=gvdwc(l,i)-gg(l)
18690       gvdwc(l,j)=gvdwc(l,j)+gg(l)
18691       enddo
18692
18693       return
18694       end subroutine dyn_ssbond_ene
18695 !--------------------------------------------------------------------------
18696        subroutine triple_ssbond_ene(resi,resj,resk,eij)
18697 !      implicit none
18698 !      Includes
18699       use calc_data
18700       use comm_sschecks
18701 !      include 'DIMENSIONS'
18702 !      include 'COMMON.SBRIDGE'
18703 !      include 'COMMON.CHAIN'
18704 !      include 'COMMON.DERIV'
18705 !      include 'COMMON.LOCAL'
18706 !      include 'COMMON.INTERACT'
18707 !      include 'COMMON.VAR'
18708 !      include 'COMMON.IOUNITS'
18709 !      include 'COMMON.CALC'
18710 #ifndef CLUST
18711 #ifndef WHAM
18712        use MD_data
18713 !      include 'COMMON.MD'
18714 !      use MD, only: totT,t_bath
18715 #endif
18716 #endif
18717       double precision h_base
18718       external h_base
18719
18720 !c     Input arguments
18721       integer resi,resj,resk,m,itypi,itypj,itypk
18722
18723 !c     Output arguments
18724       double precision eij,eij1,eij2,eij3
18725
18726 !c     Local variables
18727       logical havebond
18728 !c      integer itypi,itypj,k,l
18729       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
18730       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
18731       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
18732       double precision sig0ij,ljd,sig,fac,e1,e2
18733       double precision dcosom1(3),dcosom2(3),ed
18734       double precision pom1,pom2
18735       double precision ljA,ljB,ljXs
18736       double precision d_ljB(1:3)
18737       double precision ssA,ssB,ssC,ssXs
18738       double precision ssxm,ljxm,ssm,ljm
18739       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
18740       eij=0.0
18741       if (dtriss.eq.0) return
18742       i=resi
18743       j=resj
18744       k=resk
18745 !C      write(iout,*) resi,resj,resk
18746       itypi=itype(i,1)
18747       dxi=dc_norm(1,nres+i)
18748       dyi=dc_norm(2,nres+i)
18749       dzi=dc_norm(3,nres+i)
18750       dsci_inv=vbld_inv(i+nres)
18751       xi=c(1,nres+i)
18752       yi=c(2,nres+i)
18753       zi=c(3,nres+i)
18754       call to_box(xi,yi,zi)
18755       itypj=itype(j,1)
18756       xj=c(1,nres+j)
18757       yj=c(2,nres+j)
18758       zj=c(3,nres+j)
18759       call to_box(xj,yj,zj)
18760       dxj=dc_norm(1,nres+j)
18761       dyj=dc_norm(2,nres+j)
18762       dzj=dc_norm(3,nres+j)
18763       dscj_inv=vbld_inv(j+nres)
18764       itypk=itype(k,1)
18765       xk=c(1,nres+k)
18766       yk=c(2,nres+k)
18767       zk=c(3,nres+k)
18768        call to_box(xk,yk,zk)
18769       dxk=dc_norm(1,nres+k)
18770       dyk=dc_norm(2,nres+k)
18771       dzk=dc_norm(3,nres+k)
18772       dscj_inv=vbld_inv(k+nres)
18773       xij=xj-xi
18774       xik=xk-xi
18775       xjk=xk-xj
18776       yij=yj-yi
18777       yik=yk-yi
18778       yjk=yk-yj
18779       zij=zj-zi
18780       zik=zk-zi
18781       zjk=zk-zj
18782       rrij=(xij*xij+yij*yij+zij*zij)
18783       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18784       rrik=(xik*xik+yik*yik+zik*zik)
18785       rik=dsqrt(rrik)
18786       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
18787       rjk=dsqrt(rrjk)
18788 !C there are three combination of distances for each trisulfide bonds
18789 !C The first case the ith atom is the center
18790 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
18791 !C distance y is second distance the a,b,c,d are parameters derived for
18792 !C this problem d parameter was set as a penalty currenlty set to 1.
18793       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
18794       eij1=0.0d0
18795       else
18796       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
18797       endif
18798 !C second case jth atom is center
18799       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
18800       eij2=0.0d0
18801       else
18802       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
18803       endif
18804 !C the third case kth atom is the center
18805       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
18806       eij3=0.0d0
18807       else
18808       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
18809       endif
18810 !C      eij2=0.0
18811 !C      eij3=0.0
18812 !C      eij1=0.0
18813       eij=eij1+eij2+eij3
18814 !C      write(iout,*)i,j,k,eij
18815 !C The energy penalty calculated now time for the gradient part
18816 !C derivative over rij
18817       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18818       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
18819           gg(1)=xij*fac/rij
18820           gg(2)=yij*fac/rij
18821           gg(3)=zij*fac/rij
18822       do m=1,3
18823       gvdwx(m,i)=gvdwx(m,i)-gg(m)
18824       gvdwx(m,j)=gvdwx(m,j)+gg(m)
18825       enddo
18826
18827       do l=1,3
18828       gvdwc(l,i)=gvdwc(l,i)-gg(l)
18829       gvdwc(l,j)=gvdwc(l,j)+gg(l)
18830       enddo
18831 !C now derivative over rik
18832       fac=-eij1**2/dtriss* &
18833       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18834       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18835           gg(1)=xik*fac/rik
18836           gg(2)=yik*fac/rik
18837           gg(3)=zik*fac/rik
18838       do m=1,3
18839       gvdwx(m,i)=gvdwx(m,i)-gg(m)
18840       gvdwx(m,k)=gvdwx(m,k)+gg(m)
18841       enddo
18842       do l=1,3
18843       gvdwc(l,i)=gvdwc(l,i)-gg(l)
18844       gvdwc(l,k)=gvdwc(l,k)+gg(l)
18845       enddo
18846 !C now derivative over rjk
18847       fac=-eij2**2/dtriss* &
18848       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
18849       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18850           gg(1)=xjk*fac/rjk
18851           gg(2)=yjk*fac/rjk
18852           gg(3)=zjk*fac/rjk
18853       do m=1,3
18854       gvdwx(m,j)=gvdwx(m,j)-gg(m)
18855       gvdwx(m,k)=gvdwx(m,k)+gg(m)
18856       enddo
18857       do l=1,3
18858       gvdwc(l,j)=gvdwc(l,j)-gg(l)
18859       gvdwc(l,k)=gvdwc(l,k)+gg(l)
18860       enddo
18861       return
18862       end subroutine triple_ssbond_ene
18863
18864
18865
18866 !-----------------------------------------------------------------------------
18867       real(kind=8) function h_base(x,deriv)
18868 !     A smooth function going 0->1 in range [0,1]
18869 !     It should NOT be called outside range [0,1], it will not work there.
18870       implicit none
18871
18872 !     Input arguments
18873       real(kind=8) :: x
18874
18875 !     Output arguments
18876       real(kind=8) :: deriv
18877
18878 !     Local variables
18879       real(kind=8) :: xsq
18880
18881
18882 !     Two parabolas put together.  First derivative zero at extrema
18883 !$$$      if (x.lt.0.5D0) then
18884 !$$$        h_base=2.0D0*x*x
18885 !$$$        deriv=4.0D0*x
18886 !$$$      else
18887 !$$$        deriv=1.0D0-x
18888 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
18889 !$$$        deriv=4.0D0*deriv
18890 !$$$      endif
18891
18892 !     Third degree polynomial.  First derivative zero at extrema
18893       h_base=x*x*(3.0d0-2.0d0*x)
18894       deriv=6.0d0*x*(1.0d0-x)
18895
18896 !     Fifth degree polynomial.  First and second derivatives zero at extrema
18897 !$$$      xsq=x*x
18898 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
18899 !$$$      deriv=x-1.0d0
18900 !$$$      deriv=deriv*deriv
18901 !$$$      deriv=30.0d0*xsq*deriv
18902
18903       return
18904       end function h_base
18905 !-----------------------------------------------------------------------------
18906       subroutine dyn_set_nss
18907 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
18908 !      implicit none
18909       use MD_data, only: totT,t_bath
18910 !     Includes
18911 !      include 'DIMENSIONS'
18912 #ifdef MPI
18913       include "mpif.h"
18914 #endif
18915 !      include 'COMMON.SBRIDGE'
18916 !      include 'COMMON.CHAIN'
18917 !      include 'COMMON.IOUNITS'
18918 !      include 'COMMON.SETUP'
18919 !      include 'COMMON.MD'
18920 !     Local variables
18921       real(kind=8) :: emin
18922       integer :: i,j,imin,ierr
18923       integer :: diff,allnss,newnss
18924       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18925             newihpb,newjhpb
18926       logical :: found
18927       integer,dimension(0:nfgtasks) :: i_newnss
18928       integer,dimension(0:nfgtasks) :: displ
18929       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18930       integer :: g_newnss
18931
18932       allnss=0
18933       do i=1,nres-1
18934       do j=i+1,nres
18935         if (dyn_ssbond_ij(i,j).lt.1.0d300) then
18936           allnss=allnss+1
18937           allflag(allnss)=0
18938           allihpb(allnss)=i
18939           alljhpb(allnss)=j
18940         endif
18941       enddo
18942       enddo
18943
18944 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18945
18946  1    emin=1.0d300
18947       do i=1,allnss
18948       if (allflag(i).eq.0 .and. &
18949            dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
18950         emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
18951         imin=i
18952       endif
18953       enddo
18954       if (emin.lt.1.0d300) then
18955       allflag(imin)=1
18956       do i=1,allnss
18957         if (allflag(i).eq.0 .and. &
18958              (allihpb(i).eq.allihpb(imin) .or. &
18959              alljhpb(i).eq.allihpb(imin) .or. &
18960              allihpb(i).eq.alljhpb(imin) .or. &
18961              alljhpb(i).eq.alljhpb(imin))) then
18962           allflag(i)=-1
18963         endif
18964       enddo
18965       goto 1
18966       endif
18967
18968 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18969
18970       newnss=0
18971       do i=1,allnss
18972       if (allflag(i).eq.1) then
18973         newnss=newnss+1
18974         newihpb(newnss)=allihpb(i)
18975         newjhpb(newnss)=alljhpb(i)
18976       endif
18977       enddo
18978
18979 #ifdef MPI
18980       if (nfgtasks.gt.1)then
18981
18982       call MPI_Reduce(newnss,g_newnss,1,&
18983         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
18984       call MPI_Gather(newnss,1,MPI_INTEGER,&
18985                   i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
18986       displ(0)=0
18987       do i=1,nfgtasks-1,1
18988         displ(i)=i_newnss(i-1)+displ(i-1)
18989       enddo
18990       call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
18991                    g_newihpb,i_newnss,displ,MPI_INTEGER,&
18992                    king,FG_COMM,IERR)
18993       call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
18994                    g_newjhpb,i_newnss,displ,MPI_INTEGER,&
18995                    king,FG_COMM,IERR)
18996       if(fg_rank.eq.0) then
18997 !         print *,'g_newnss',g_newnss
18998 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
18999 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
19000        newnss=g_newnss
19001        do i=1,newnss
19002         newihpb(i)=g_newihpb(i)
19003         newjhpb(i)=g_newjhpb(i)
19004        enddo
19005       endif
19006       endif
19007 #endif
19008
19009       diff=newnss-nss
19010
19011 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
19012 !       print *,newnss,nss,maxdim
19013       do i=1,nss
19014       found=.false.
19015 !        print *,newnss
19016       do j=1,newnss
19017 !!          print *,j
19018         if (idssb(i).eq.newihpb(j) .and. &
19019              jdssb(i).eq.newjhpb(j)) found=.true.
19020       enddo
19021 #ifndef CLUST
19022 #ifndef WHAM
19023 !        write(iout,*) "found",found,i,j
19024       if (.not.found.and.fg_rank.eq.0) &
19025           write(iout,'(a15,f12.2,f8.1,2i5)') &
19026            "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
19027 #endif
19028 #endif
19029       enddo
19030
19031       do i=1,newnss
19032       found=.false.
19033       do j=1,nss
19034 !          print *,i,j
19035         if (newihpb(i).eq.idssb(j) .and. &
19036              newjhpb(i).eq.jdssb(j)) found=.true.
19037       enddo
19038 #ifndef CLUST
19039 #ifndef WHAM
19040 !        write(iout,*) "found",found,i,j
19041       if (.not.found.and.fg_rank.eq.0) &
19042           write(iout,'(a15,f12.2,f8.1,2i5)') &
19043            "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
19044 #endif
19045 #endif
19046       enddo
19047
19048       nss=newnss
19049       do i=1,nss
19050       idssb(i)=newihpb(i)
19051       jdssb(i)=newjhpb(i)
19052       enddo
19053
19054       return
19055       end subroutine dyn_set_nss
19056 ! Lipid transfer energy function
19057       subroutine Eliptransfer(eliptran)
19058 !C this is done by Adasko
19059 !C      print *,"wchodze"
19060 !C structure of box:
19061 !C      water
19062 !C--bordliptop-- buffore starts
19063 !C--bufliptop--- here true lipid starts
19064 !C      lipid
19065 !C--buflipbot--- lipid ends buffore starts
19066 !C--bordlipbot--buffore ends
19067       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
19068       integer :: i
19069       eliptran=0.0
19070 !      print *, "I am in eliptran"
19071       do i=ilip_start,ilip_end
19072 !C       do i=1,1
19073       if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
19074        cycle
19075
19076       positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
19077       if (positi.le.0.0) positi=positi+boxzsize
19078 !C        print *,i
19079 !C first for peptide groups
19080 !c for each residue check if it is in lipid or lipid water border area
19081        if ((positi.gt.bordlipbot)  &
19082       .and.(positi.lt.bordliptop)) then
19083 !C the energy transfer exist
19084       if (positi.lt.buflipbot) then
19085 !C what fraction I am in
19086        fracinbuf=1.0d0-      &
19087            ((positi-bordlipbot)/lipbufthick)
19088 !C lipbufthick is thickenes of lipid buffore
19089        sslip=sscalelip(fracinbuf)
19090        ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19091        eliptran=eliptran+sslip*pepliptran
19092        gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19093        gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19094 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19095
19096 !C        print *,"doing sccale for lower part"
19097 !C         print *,i,sslip,fracinbuf,ssgradlip
19098       elseif (positi.gt.bufliptop) then
19099        fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
19100        sslip=sscalelip(fracinbuf)
19101        ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19102        eliptran=eliptran+sslip*pepliptran
19103        gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19104        gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19105 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19106 !C          print *, "doing sscalefor top part"
19107 !C         print *,i,sslip,fracinbuf,ssgradlip
19108       else
19109        eliptran=eliptran+pepliptran
19110 !C         print *,"I am in true lipid"
19111       endif
19112 !C       else
19113 !C       eliptran=elpitran+0.0 ! I am in water
19114        endif
19115        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
19116        enddo
19117 ! here starts the side chain transfer
19118        do i=ilip_start,ilip_end
19119       if (itype(i,1).eq.ntyp1) cycle
19120       positi=(mod(c(3,i+nres),boxzsize))
19121       if (positi.le.0) positi=positi+boxzsize
19122 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19123 !c for each residue check if it is in lipid or lipid water border area
19124 !C       respos=mod(c(3,i+nres),boxzsize)
19125 !C       print *,positi,bordlipbot,buflipbot
19126        if ((positi.gt.bordlipbot) &
19127        .and.(positi.lt.bordliptop)) then
19128 !C the energy transfer exist
19129       if (positi.lt.buflipbot) then
19130        fracinbuf=1.0d0-   &
19131          ((positi-bordlipbot)/lipbufthick)
19132 !C lipbufthick is thickenes of lipid buffore
19133        sslip=sscalelip(fracinbuf)
19134        ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19135        eliptran=eliptran+sslip*liptranene(itype(i,1))
19136        gliptranx(3,i)=gliptranx(3,i) &
19137       +ssgradlip*liptranene(itype(i,1))
19138        gliptranc(3,i-1)= gliptranc(3,i-1) &
19139       +ssgradlip*liptranene(itype(i,1))
19140 !C         print *,"doing sccale for lower part"
19141       elseif (positi.gt.bufliptop) then
19142        fracinbuf=1.0d0-  &
19143       ((bordliptop-positi)/lipbufthick)
19144        sslip=sscalelip(fracinbuf)
19145        ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19146        eliptran=eliptran+sslip*liptranene(itype(i,1))
19147        gliptranx(3,i)=gliptranx(3,i)  &
19148        +ssgradlip*liptranene(itype(i,1))
19149        gliptranc(3,i-1)= gliptranc(3,i-1) &
19150       +ssgradlip*liptranene(itype(i,1))
19151 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19152       else
19153        eliptran=eliptran+liptranene(itype(i,1))
19154 !C         print *,"I am in true lipid"
19155       endif
19156       endif ! if in lipid or buffor
19157 !C       else
19158 !C       eliptran=elpitran+0.0 ! I am in water
19159       if (energy_dec) write(iout,*) i,"eliptran=",eliptran
19160        enddo
19161        return
19162        end  subroutine Eliptransfer
19163 !----------------------------------NANO FUNCTIONS
19164 !C-----------------------------------------------------------------------
19165 !C-----------------------------------------------------------
19166 !C This subroutine is to mimic the histone like structure but as well can be
19167 !C utilizet to nanostructures (infinit) small modification has to be used to
19168 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19169 !C gradient has to be modified at the ends
19170 !C The energy function is Kihara potential
19171 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19172 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19173 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19174 !C simple Kihara potential
19175       subroutine calctube(Etube)
19176       real(kind=8),dimension(3) :: vectube
19177       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19178        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
19179        sc_aa_tube,sc_bb_tube
19180       integer :: i,j,iti
19181       Etube=0.0d0
19182       do i=itube_start,itube_end
19183       enetube(i)=0.0d0
19184       enetube(i+nres)=0.0d0
19185       enddo
19186 !C first we calculate the distance from tube center
19187 !C for UNRES
19188        do i=itube_start,itube_end
19189 !C lets ommit dummy atoms for now
19190        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19191 !C now calculate distance from center of tube and direction vectors
19192       xmin=boxxsize
19193       ymin=boxysize
19194 ! Find minimum distance in periodic box
19195       do j=-1,1
19196        vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19197        vectube(1)=vectube(1)+boxxsize*j
19198        vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19199        vectube(2)=vectube(2)+boxysize*j
19200        xminact=abs(vectube(1)-tubecenter(1))
19201        yminact=abs(vectube(2)-tubecenter(2))
19202          if (xmin.gt.xminact) then
19203           xmin=xminact
19204           xtemp=vectube(1)
19205          endif
19206          if (ymin.gt.yminact) then
19207            ymin=yminact
19208            ytemp=vectube(2)
19209           endif
19210        enddo
19211       vectube(1)=xtemp
19212       vectube(2)=ytemp
19213       vectube(1)=vectube(1)-tubecenter(1)
19214       vectube(2)=vectube(2)-tubecenter(2)
19215
19216 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19217 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19218
19219 !C as the tube is infinity we do not calculate the Z-vector use of Z
19220 !C as chosen axis
19221       vectube(3)=0.0d0
19222 !C now calculte the distance
19223        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19224 !C now normalize vector
19225       vectube(1)=vectube(1)/tub_r
19226       vectube(2)=vectube(2)/tub_r
19227 !C calculte rdiffrence between r and r0
19228       rdiff=tub_r-tubeR0
19229 !C and its 6 power
19230       rdiff6=rdiff**6.0d0
19231 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19232        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19233 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19234 !C       print *,rdiff,rdiff6,pep_aa_tube
19235 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19236 !C now we calculate gradient
19237        fac=(-12.0d0*pep_aa_tube/rdiff6- &
19238           6.0d0*pep_bb_tube)/rdiff6/rdiff
19239 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19240 !C     &rdiff,fac
19241 !C now direction of gg_tube vector
19242       do j=1,3
19243       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19244       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19245       enddo
19246       enddo
19247 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19248 !C        print *,gg_tube(1,0),"TU"
19249
19250
19251        do i=itube_start,itube_end
19252 !C Lets not jump over memory as we use many times iti
19253        iti=itype(i,1)
19254 !C lets ommit dummy atoms for now
19255        if ((iti.eq.ntyp1)  &
19256 !C in UNRES uncomment the line below as GLY has no side-chain...
19257 !C      .or.(iti.eq.10)
19258       ) cycle
19259       xmin=boxxsize
19260       ymin=boxysize
19261       do j=-1,1
19262        vectube(1)=mod((c(1,i+nres)),boxxsize)
19263        vectube(1)=vectube(1)+boxxsize*j
19264        vectube(2)=mod((c(2,i+nres)),boxysize)
19265        vectube(2)=vectube(2)+boxysize*j
19266
19267        xminact=abs(vectube(1)-tubecenter(1))
19268        yminact=abs(vectube(2)-tubecenter(2))
19269          if (xmin.gt.xminact) then
19270           xmin=xminact
19271           xtemp=vectube(1)
19272          endif
19273          if (ymin.gt.yminact) then
19274            ymin=yminact
19275            ytemp=vectube(2)
19276           endif
19277        enddo
19278       vectube(1)=xtemp
19279       vectube(2)=ytemp
19280 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19281 !C     &     tubecenter(2)
19282       vectube(1)=vectube(1)-tubecenter(1)
19283       vectube(2)=vectube(2)-tubecenter(2)
19284
19285 !C as the tube is infinity we do not calculate the Z-vector use of Z
19286 !C as chosen axis
19287       vectube(3)=0.0d0
19288 !C now calculte the distance
19289        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19290 !C now normalize vector
19291       vectube(1)=vectube(1)/tub_r
19292       vectube(2)=vectube(2)/tub_r
19293
19294 !C calculte rdiffrence between r and r0
19295       rdiff=tub_r-tubeR0
19296 !C and its 6 power
19297       rdiff6=rdiff**6.0d0
19298 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19299        sc_aa_tube=sc_aa_tube_par(iti)
19300        sc_bb_tube=sc_bb_tube_par(iti)
19301        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19302        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
19303            6.0d0*sc_bb_tube/rdiff6/rdiff
19304 !C now direction of gg_tube vector
19305        do j=1,3
19306         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19307         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19308        enddo
19309       enddo
19310       do i=itube_start,itube_end
19311         Etube=Etube+enetube(i)+enetube(i+nres)
19312       enddo
19313 !C        print *,"ETUBE", etube
19314       return
19315       end subroutine calctube
19316 !C TO DO 1) add to total energy
19317 !C       2) add to gradient summation
19318 !C       3) add reading parameters (AND of course oppening of PARAM file)
19319 !C       4) add reading the center of tube
19320 !C       5) add COMMONs
19321 !C       6) add to zerograd
19322 !C       7) allocate matrices
19323
19324
19325 !C-----------------------------------------------------------------------
19326 !C-----------------------------------------------------------
19327 !C This subroutine is to mimic the histone like structure but as well can be
19328 !C utilizet to nanostructures (infinit) small modification has to be used to
19329 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19330 !C gradient has to be modified at the ends
19331 !C The energy function is Kihara potential
19332 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19333 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19334 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19335 !C simple Kihara potential
19336       subroutine calctube2(Etube)
19337           real(kind=8),dimension(3) :: vectube
19338       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19339        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
19340        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
19341       integer:: i,j,iti
19342       Etube=0.0d0
19343       do i=itube_start,itube_end
19344       enetube(i)=0.0d0
19345       enetube(i+nres)=0.0d0
19346       enddo
19347 !C first we calculate the distance from tube center
19348 !C first sugare-phosphate group for NARES this would be peptide group
19349 !C for UNRES
19350        do i=itube_start,itube_end
19351 !C lets ommit dummy atoms for now
19352
19353        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19354 !C now calculate distance from center of tube and direction vectors
19355 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19356 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19357 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19358 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19359       xmin=boxxsize
19360       ymin=boxysize
19361       do j=-1,1
19362        vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19363        vectube(1)=vectube(1)+boxxsize*j
19364        vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19365        vectube(2)=vectube(2)+boxysize*j
19366
19367        xminact=abs(vectube(1)-tubecenter(1))
19368        yminact=abs(vectube(2)-tubecenter(2))
19369          if (xmin.gt.xminact) then
19370           xmin=xminact
19371           xtemp=vectube(1)
19372          endif
19373          if (ymin.gt.yminact) then
19374            ymin=yminact
19375            ytemp=vectube(2)
19376           endif
19377        enddo
19378       vectube(1)=xtemp
19379       vectube(2)=ytemp
19380       vectube(1)=vectube(1)-tubecenter(1)
19381       vectube(2)=vectube(2)-tubecenter(2)
19382
19383 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19384 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19385
19386 !C as the tube is infinity we do not calculate the Z-vector use of Z
19387 !C as chosen axis
19388       vectube(3)=0.0d0
19389 !C now calculte the distance
19390        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19391 !C now normalize vector
19392       vectube(1)=vectube(1)/tub_r
19393       vectube(2)=vectube(2)/tub_r
19394 !C calculte rdiffrence between r and r0
19395       rdiff=tub_r-tubeR0
19396 !C and its 6 power
19397       rdiff6=rdiff**6.0d0
19398 !C THIS FRAGMENT MAKES TUBE FINITE
19399       positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19400       if (positi.le.0) positi=positi+boxzsize
19401 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19402 !c for each residue check if it is in lipid or lipid water border area
19403 !C       respos=mod(c(3,i+nres),boxzsize)
19404 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19405        if ((positi.gt.bordtubebot)  &
19406       .and.(positi.lt.bordtubetop)) then
19407 !C the energy transfer exist
19408       if (positi.lt.buftubebot) then
19409        fracinbuf=1.0d0-  &
19410          ((positi-bordtubebot)/tubebufthick)
19411 !C lipbufthick is thickenes of lipid buffore
19412        sstube=sscalelip(fracinbuf)
19413        ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19414 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19415        enetube(i)=enetube(i)+sstube*tubetranenepep
19416 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19417 !C     &+ssgradtube*tubetranene(itype(i,1))
19418 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19419 !C     &+ssgradtube*tubetranene(itype(i,1))
19420 !C         print *,"doing sccale for lower part"
19421       elseif (positi.gt.buftubetop) then
19422        fracinbuf=1.0d0-  &
19423       ((bordtubetop-positi)/tubebufthick)
19424        sstube=sscalelip(fracinbuf)
19425        ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19426        enetube(i)=enetube(i)+sstube*tubetranenepep
19427 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19428 !C     &+ssgradtube*tubetranene(itype(i,1))
19429 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19430 !C     &+ssgradtube*tubetranene(itype(i,1))
19431 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19432       else
19433        sstube=1.0d0
19434        ssgradtube=0.0d0
19435        enetube(i)=enetube(i)+sstube*tubetranenepep
19436 !C         print *,"I am in true lipid"
19437       endif
19438       else
19439 !C          sstube=0.0d0
19440 !C          ssgradtube=0.0d0
19441       cycle
19442       endif ! if in lipid or buffor
19443
19444 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19445        enetube(i)=enetube(i)+sstube* &
19446       (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
19447 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19448 !C       print *,rdiff,rdiff6,pep_aa_tube
19449 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19450 !C now we calculate gradient
19451        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
19452            6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
19453 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19454 !C     &rdiff,fac
19455
19456 !C now direction of gg_tube vector
19457        do j=1,3
19458       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19459       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19460       enddo
19461        gg_tube(3,i)=gg_tube(3,i)  &
19462        +ssgradtube*enetube(i)/sstube/2.0d0
19463        gg_tube(3,i-1)= gg_tube(3,i-1)  &
19464        +ssgradtube*enetube(i)/sstube/2.0d0
19465
19466       enddo
19467 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19468 !C        print *,gg_tube(1,0),"TU"
19469       do i=itube_start,itube_end
19470 !C Lets not jump over memory as we use many times iti
19471        iti=itype(i,1)
19472 !C lets ommit dummy atoms for now
19473        if ((iti.eq.ntyp1) &
19474 !!C in UNRES uncomment the line below as GLY has no side-chain...
19475          .or.(iti.eq.10) &
19476         ) cycle
19477         vectube(1)=c(1,i+nres)
19478         vectube(1)=mod(vectube(1),boxxsize)
19479         if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19480         vectube(2)=c(2,i+nres)
19481         vectube(2)=mod(vectube(2),boxysize)
19482         if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19483
19484       vectube(1)=vectube(1)-tubecenter(1)
19485       vectube(2)=vectube(2)-tubecenter(2)
19486 !C THIS FRAGMENT MAKES TUBE FINITE
19487       positi=(mod(c(3,i+nres),boxzsize))
19488       if (positi.le.0) positi=positi+boxzsize
19489 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19490 !c for each residue check if it is in lipid or lipid water border area
19491 !C       respos=mod(c(3,i+nres),boxzsize)
19492 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19493
19494        if ((positi.gt.bordtubebot)  &
19495       .and.(positi.lt.bordtubetop)) then
19496 !C the energy transfer exist
19497       if (positi.lt.buftubebot) then
19498        fracinbuf=1.0d0- &
19499           ((positi-bordtubebot)/tubebufthick)
19500 !C lipbufthick is thickenes of lipid buffore
19501        sstube=sscalelip(fracinbuf)
19502        ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19503 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19504        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19505 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19506 !C     &+ssgradtube*tubetranene(itype(i,1))
19507 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19508 !C     &+ssgradtube*tubetranene(itype(i,1))
19509 !C         print *,"doing sccale for lower part"
19510       elseif (positi.gt.buftubetop) then
19511        fracinbuf=1.0d0- &
19512       ((bordtubetop-positi)/tubebufthick)
19513
19514        sstube=sscalelip(fracinbuf)
19515        ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19516        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19517 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19518 !C     &+ssgradtube*tubetranene(itype(i,1))
19519 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19520 !C     &+ssgradtube*tubetranene(itype(i,1))
19521 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19522       else
19523        sstube=1.0d0
19524        ssgradtube=0.0d0
19525        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19526 !C         print *,"I am in true lipid"
19527       endif
19528       else
19529 !C          sstube=0.0d0
19530 !C          ssgradtube=0.0d0
19531       cycle
19532       endif ! if in lipid or buffor
19533 !CEND OF FINITE FRAGMENT
19534 !C as the tube is infinity we do not calculate the Z-vector use of Z
19535 !C as chosen axis
19536       vectube(3)=0.0d0
19537 !C now calculte the distance
19538        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19539 !C now normalize vector
19540       vectube(1)=vectube(1)/tub_r
19541       vectube(2)=vectube(2)/tub_r
19542 !C calculte rdiffrence between r and r0
19543       rdiff=tub_r-tubeR0
19544 !C and its 6 power
19545       rdiff6=rdiff**6.0d0
19546 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19547        sc_aa_tube=sc_aa_tube_par(iti)
19548        sc_bb_tube=sc_bb_tube_par(iti)
19549        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
19550                    *sstube+enetube(i+nres)
19551 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19552 !C now we calculate gradient
19553        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
19554           6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
19555 !C now direction of gg_tube vector
19556        do j=1,3
19557         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19558         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19559        enddo
19560        gg_tube_SC(3,i)=gg_tube_SC(3,i) &
19561        +ssgradtube*enetube(i+nres)/sstube
19562        gg_tube(3,i-1)= gg_tube(3,i-1) &
19563        +ssgradtube*enetube(i+nres)/sstube
19564
19565       enddo
19566       do i=itube_start,itube_end
19567         Etube=Etube+enetube(i)+enetube(i+nres)
19568       enddo
19569 !C        print *,"ETUBE", etube
19570       return
19571       end subroutine calctube2
19572 !=====================================================================================================================================
19573       subroutine calcnano(Etube)
19574       real(kind=8),dimension(3) :: vectube
19575
19576       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19577        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
19578        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
19579        integer:: i,j,iti,r
19580
19581       Etube=0.0d0
19582 !      print *,itube_start,itube_end,"poczatek"
19583       do i=itube_start,itube_end
19584       enetube(i)=0.0d0
19585       enetube(i+nres)=0.0d0
19586       enddo
19587 !C first we calculate the distance from tube center
19588 !C first sugare-phosphate group for NARES this would be peptide group
19589 !C for UNRES
19590        do i=itube_start,itube_end
19591 !C lets ommit dummy atoms for now
19592        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19593 !C now calculate distance from center of tube and direction vectors
19594       xmin=boxxsize
19595       ymin=boxysize
19596       zmin=boxzsize
19597
19598       do j=-1,1
19599        vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19600        vectube(1)=vectube(1)+boxxsize*j
19601        vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19602        vectube(2)=vectube(2)+boxysize*j
19603        vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19604        vectube(3)=vectube(3)+boxzsize*j
19605
19606
19607        xminact=dabs(vectube(1)-tubecenter(1))
19608        yminact=dabs(vectube(2)-tubecenter(2))
19609        zminact=dabs(vectube(3)-tubecenter(3))
19610
19611          if (xmin.gt.xminact) then
19612           xmin=xminact
19613           xtemp=vectube(1)
19614          endif
19615          if (ymin.gt.yminact) then
19616            ymin=yminact
19617            ytemp=vectube(2)
19618           endif
19619          if (zmin.gt.zminact) then
19620            zmin=zminact
19621            ztemp=vectube(3)
19622           endif
19623        enddo
19624       vectube(1)=xtemp
19625       vectube(2)=ytemp
19626       vectube(3)=ztemp
19627
19628       vectube(1)=vectube(1)-tubecenter(1)
19629       vectube(2)=vectube(2)-tubecenter(2)
19630       vectube(3)=vectube(3)-tubecenter(3)
19631
19632 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19633 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19634 !C as the tube is infinity we do not calculate the Z-vector use of Z
19635 !C as chosen axis
19636 !C      vectube(3)=0.0d0
19637 !C now calculte the distance
19638        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19639 !C now normalize vector
19640       vectube(1)=vectube(1)/tub_r
19641       vectube(2)=vectube(2)/tub_r
19642       vectube(3)=vectube(3)/tub_r
19643 !C calculte rdiffrence between r and r0
19644       rdiff=tub_r-tubeR0
19645 !C and its 6 power
19646       rdiff6=rdiff**6.0d0
19647 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19648        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19649 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19650 !C       print *,rdiff,rdiff6,pep_aa_tube
19651 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19652 !C now we calculate gradient
19653        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
19654           6.0d0*pep_bb_tube)/rdiff6/rdiff
19655 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19656 !C     &rdiff,fac
19657        if (acavtubpep.eq.0.0d0) then
19658 !C go to 667
19659        enecavtube(i)=0.0
19660        faccav=0.0
19661        else
19662        denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
19663        enecavtube(i)=  &
19664       (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
19665       /denominator
19666        enecavtube(i)=0.0
19667        faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
19668       *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
19669       +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
19670       /denominator**2.0d0
19671 !C         faccav=0.0
19672 !C         fac=fac+faccav
19673 !C 667     continue
19674        endif
19675         if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
19676       do j=1,3
19677       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19678       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19679       enddo
19680       enddo
19681
19682        do i=itube_start,itube_end
19683       enecavtube(i)=0.0d0
19684 !C Lets not jump over memory as we use many times iti
19685        iti=itype(i,1)
19686 !C lets ommit dummy atoms for now
19687        if ((iti.eq.ntyp1) &
19688 !C in UNRES uncomment the line below as GLY has no side-chain...
19689 !C      .or.(iti.eq.10)
19690        ) cycle
19691       xmin=boxxsize
19692       ymin=boxysize
19693       zmin=boxzsize
19694       do j=-1,1
19695        vectube(1)=dmod((c(1,i+nres)),boxxsize)
19696        vectube(1)=vectube(1)+boxxsize*j
19697        vectube(2)=dmod((c(2,i+nres)),boxysize)
19698        vectube(2)=vectube(2)+boxysize*j
19699        vectube(3)=dmod((c(3,i+nres)),boxzsize)
19700        vectube(3)=vectube(3)+boxzsize*j
19701
19702
19703        xminact=dabs(vectube(1)-tubecenter(1))
19704        yminact=dabs(vectube(2)-tubecenter(2))
19705        zminact=dabs(vectube(3)-tubecenter(3))
19706
19707          if (xmin.gt.xminact) then
19708           xmin=xminact
19709           xtemp=vectube(1)
19710          endif
19711          if (ymin.gt.yminact) then
19712            ymin=yminact
19713            ytemp=vectube(2)
19714           endif
19715          if (zmin.gt.zminact) then
19716            zmin=zminact
19717            ztemp=vectube(3)
19718           endif
19719        enddo
19720       vectube(1)=xtemp
19721       vectube(2)=ytemp
19722       vectube(3)=ztemp
19723
19724 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19725 !C     &     tubecenter(2)
19726       vectube(1)=vectube(1)-tubecenter(1)
19727       vectube(2)=vectube(2)-tubecenter(2)
19728       vectube(3)=vectube(3)-tubecenter(3)
19729 !C now calculte the distance
19730        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19731 !C now normalize vector
19732       vectube(1)=vectube(1)/tub_r
19733       vectube(2)=vectube(2)/tub_r
19734       vectube(3)=vectube(3)/tub_r
19735
19736 !C calculte rdiffrence between r and r0
19737       rdiff=tub_r-tubeR0
19738 !C and its 6 power
19739       rdiff6=rdiff**6.0d0
19740        sc_aa_tube=sc_aa_tube_par(iti)
19741        sc_bb_tube=sc_bb_tube_par(iti)
19742        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19743 !C       enetube(i+nres)=0.0d0
19744 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19745 !C now we calculate gradient
19746        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
19747           6.0d0*sc_bb_tube/rdiff6/rdiff
19748 !C       fac=0.0
19749 !C now direction of gg_tube vector
19750 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
19751        if (acavtub(iti).eq.0.0d0) then
19752 !C go to 667
19753        enecavtube(i+nres)=0.0d0
19754        faccav=0.0d0
19755        else
19756        denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
19757        enecavtube(i+nres)=   &
19758       (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
19759       /denominator
19760 !C         enecavtube(i)=0.0
19761        faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
19762       *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
19763       +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
19764       /denominator**2.0d0
19765 !C         faccav=0.0
19766        fac=fac+faccav
19767 !C 667     continue
19768        endif
19769 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
19770 !C     &   enecavtube(i),faccav
19771 !C         print *,"licz=",
19772 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
19773 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
19774        do j=1,3
19775         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19776         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19777        enddo
19778         if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
19779       enddo
19780
19781
19782
19783       do i=itube_start,itube_end
19784         Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
19785        +enecavtube(i+nres)
19786       enddo
19787 !        do i=1,20
19788 !         print *,"begin", i,"a"
19789 !         do r=1,10000
19790 !          rdiff=r/100.0d0
19791 !          rdiff6=rdiff**6.0d0
19792 !          sc_aa_tube=sc_aa_tube_par(i)
19793 !          sc_bb_tube=sc_bb_tube_par(i)
19794 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19795 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
19796 !          enecavtube(i)=   &
19797 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
19798 !         /denominator
19799
19800 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
19801 !         enddo
19802 !         print *,"end",i,"a"
19803 !        enddo
19804 !C        print *,"ETUBE", etube
19805       return
19806       end subroutine calcnano
19807
19808 !===============================================
19809 !--------------------------------------------------------------------------------
19810 !C first for shielding is setting of function of side-chains
19811
19812        subroutine set_shield_fac2
19813        real(kind=8) :: div77_81=0.974996043d0, &
19814       div4_81=0.2222222222d0
19815        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
19816        scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
19817        short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
19818        sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
19819 !C the vector between center of side_chain and peptide group
19820        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
19821        pept_group,costhet_grad,cosphi_grad_long, &
19822        cosphi_grad_loc,pep_side_norm,side_calf_norm, &
19823        sh_frac_dist_grad,pep_side
19824       integer i,j,k
19825 !C      write(2,*) "ivec",ivec_start,ivec_end
19826       do i=1,nres
19827       fac_shield(i)=0.0d0
19828       ishield_list(i)=0
19829       do j=1,3
19830       grad_shield(j,i)=0.0d0
19831       enddo
19832       enddo
19833       do i=ivec_start,ivec_end
19834 !C      do i=1,nres-1
19835 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19836 !      ishield_list(i)=0
19837       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19838 !Cif there two consequtive dummy atoms there is no peptide group between them
19839 !C the line below has to be changed for FGPROC>1
19840       VolumeTotal=0.0
19841       do k=1,nres
19842        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
19843        dist_pep_side=0.0
19844        dist_side_calf=0.0
19845        do j=1,3
19846 !C first lets set vector conecting the ithe side-chain with kth side-chain
19847       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
19848 !C      pep_side(j)=2.0d0
19849 !C and vector conecting the side-chain with its proper calfa
19850       side_calf(j)=c(j,k+nres)-c(j,k)
19851 !C      side_calf(j)=2.0d0
19852       pept_group(j)=c(j,i)-c(j,i+1)
19853 !C lets have their lenght
19854       dist_pep_side=pep_side(j)**2+dist_pep_side
19855       dist_side_calf=dist_side_calf+side_calf(j)**2
19856       dist_pept_group=dist_pept_group+pept_group(j)**2
19857       enddo
19858        dist_pep_side=sqrt(dist_pep_side)
19859        dist_pept_group=sqrt(dist_pept_group)
19860        dist_side_calf=sqrt(dist_side_calf)
19861       do j=1,3
19862       pep_side_norm(j)=pep_side(j)/dist_pep_side
19863       side_calf_norm(j)=dist_side_calf
19864       enddo
19865 !C now sscale fraction
19866        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
19867 !       print *,buff_shield,"buff",sh_frac_dist
19868 !C now sscale
19869       if (sh_frac_dist.le.0.0) cycle
19870 !C        print *,ishield_list(i),i
19871 !C If we reach here it means that this side chain reaches the shielding sphere
19872 !C Lets add him to the list for gradient
19873       ishield_list(i)=ishield_list(i)+1
19874 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
19875 !C this list is essential otherwise problem would be O3
19876       shield_list(ishield_list(i),i)=k
19877 !C Lets have the sscale value
19878       if (sh_frac_dist.gt.1.0) then
19879        scale_fac_dist=1.0d0
19880        do j=1,3
19881        sh_frac_dist_grad(j)=0.0d0
19882        enddo
19883       else
19884        scale_fac_dist=-sh_frac_dist*sh_frac_dist &
19885                   *(2.0d0*sh_frac_dist-3.0d0)
19886        fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
19887                    /dist_pep_side/buff_shield*0.5d0
19888        do j=1,3
19889        sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
19890 !C         sh_frac_dist_grad(j)=0.0d0
19891 !C         scale_fac_dist=1.0d0
19892 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
19893 !C     &                    sh_frac_dist_grad(j)
19894        enddo
19895       endif
19896 !C this is what is now we have the distance scaling now volume...
19897       short=short_r_sidechain(itype(k,1))
19898       long=long_r_sidechain(itype(k,1))
19899       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
19900       sinthet=short/dist_pep_side*costhet
19901 !      print *,"SORT",short,long,sinthet,costhet
19902 !C now costhet_grad
19903 !C       costhet=0.6d0
19904 !C       sinthet=0.8
19905        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
19906 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
19907 !C     &             -short/dist_pep_side**2/costhet)
19908 !C       costhet_fac=0.0d0
19909        do j=1,3
19910        costhet_grad(j)=costhet_fac*pep_side(j)
19911        enddo
19912 !C remember for the final gradient multiply costhet_grad(j)
19913 !C for side_chain by factor -2 !
19914 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
19915 !C pep_side0pept_group is vector multiplication
19916       pep_side0pept_group=0.0d0
19917       do j=1,3
19918       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
19919       enddo
19920       cosalfa=(pep_side0pept_group/ &
19921       (dist_pep_side*dist_side_calf))
19922       fac_alfa_sin=1.0d0-cosalfa**2
19923       fac_alfa_sin=dsqrt(fac_alfa_sin)
19924       rkprim=fac_alfa_sin*(long-short)+short
19925 !C      rkprim=short
19926
19927 !C now costhet_grad
19928        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
19929 !C       cosphi=0.6
19930        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
19931        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
19932          dist_pep_side**2)
19933 !C       sinphi=0.8
19934        do j=1,3
19935        cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
19936       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19937       *(long-short)/fac_alfa_sin*cosalfa/ &
19938       ((dist_pep_side*dist_side_calf))* &
19939       ((side_calf(j))-cosalfa* &
19940       ((pep_side(j)/dist_pep_side)*dist_side_calf))
19941 !C       cosphi_grad_long(j)=0.0d0
19942       cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19943       *(long-short)/fac_alfa_sin*cosalfa &
19944       /((dist_pep_side*dist_side_calf))* &
19945       (pep_side(j)- &
19946       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
19947 !C       cosphi_grad_loc(j)=0.0d0
19948        enddo
19949 !C      print *,sinphi,sinthet
19950       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
19951                    /VSolvSphere_div
19952 !C     &                    *wshield
19953 !C now the gradient...
19954       do j=1,3
19955       grad_shield(j,i)=grad_shield(j,i) &
19956 !C gradient po skalowaniu
19957                  +(sh_frac_dist_grad(j)*VofOverlap &
19958 !C  gradient po costhet
19959           +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
19960       (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
19961           sinphi/sinthet*costhet*costhet_grad(j) &
19962          +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19963       )*wshield
19964 !C grad_shield_side is Cbeta sidechain gradient
19965       grad_shield_side(j,ishield_list(i),i)=&
19966            (sh_frac_dist_grad(j)*-2.0d0&
19967            *VofOverlap&
19968           -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19969        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
19970           sinphi/sinthet*costhet*costhet_grad(j)&
19971          +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19972           )*wshield
19973 !       print *, 1.0d0/(-dsqrt(1.0d0-sinphi*sinthet)),&
19974 !            sinphi/sinthet,&
19975 !           +sinthet/sinphi,"HERE"
19976        grad_shield_loc(j,ishield_list(i),i)=   &
19977           scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19978       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
19979           sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
19980            ))&
19981            *wshield
19982 !         print *,grad_shield_loc(j,ishield_list(i),i)
19983       enddo
19984       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
19985       enddo
19986       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
19987
19988 !      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
19989       enddo
19990       return
19991       end subroutine set_shield_fac2
19992 !----------------------------------------------------------------------------
19993 ! SOUBROUTINE FOR AFM
19994        subroutine AFMvel(Eafmforce)
19995        use MD_data, only:totTafm
19996       real(kind=8),dimension(3) :: diffafm
19997       real(kind=8) :: afmdist,Eafmforce
19998        integer :: i
19999 !C Only for check grad COMMENT if not used for checkgrad
20000 !C      totT=3.0d0
20001 !C--------------------------------------------------------
20002 !C      print *,"wchodze"
20003       afmdist=0.0d0
20004       Eafmforce=0.0d0
20005       do i=1,3
20006       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20007       afmdist=afmdist+diffafm(i)**2
20008       enddo
20009       afmdist=dsqrt(afmdist)
20010 !      totTafm=3.0
20011       Eafmforce=0.5d0*forceAFMconst &
20012       *(distafminit+totTafm*velAFMconst-afmdist)**2
20013 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
20014       do i=1,3
20015       gradafm(i,afmend-1)=-forceAFMconst* &
20016        (distafminit+totTafm*velAFMconst-afmdist) &
20017        *diffafm(i)/afmdist
20018       gradafm(i,afmbeg-1)=forceAFMconst* &
20019       (distafminit+totTafm*velAFMconst-afmdist) &
20020       *diffafm(i)/afmdist
20021       enddo
20022 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
20023       return
20024       end subroutine AFMvel
20025 !---------------------------------------------------------
20026        subroutine AFMforce(Eafmforce)
20027
20028       real(kind=8),dimension(3) :: diffafm
20029 !      real(kind=8) ::afmdist
20030       real(kind=8) :: afmdist,Eafmforce
20031       integer :: i
20032       afmdist=0.0d0
20033       Eafmforce=0.0d0
20034       do i=1,3
20035       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20036       afmdist=afmdist+diffafm(i)**2
20037       enddo
20038       afmdist=dsqrt(afmdist)
20039 !      print *,afmdist,distafminit
20040       Eafmforce=-forceAFMconst*(afmdist-distafminit)
20041       do i=1,3
20042       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
20043       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
20044       enddo
20045 !C      print *,'AFM',Eafmforce
20046       return
20047       end subroutine AFMforce
20048
20049 !-----------------------------------------------------------------------------
20050 #ifdef WHAM
20051       subroutine read_ssHist
20052 !      implicit none
20053 !      Includes
20054 !      include 'DIMENSIONS'
20055 !      include "DIMENSIONS.FREE"
20056 !      include 'COMMON.FREE'
20057 !     Local variables
20058       integer :: i,j
20059       character(len=80) :: controlcard
20060
20061       do i=1,dyn_nssHist
20062       call card_concat(controlcard,.true.)
20063       read(controlcard,*) &
20064            dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
20065       enddo
20066
20067       return
20068       end subroutine read_ssHist
20069 #endif
20070 !-----------------------------------------------------------------------------
20071       integer function indmat(i,j)
20072 !el
20073 ! get the position of the jth ijth fragment of the chain coordinate system
20074 ! in the fromto array.
20075       integer :: i,j
20076
20077       indmat=((2*(nres-2)-i)*(i-1))/2+j-1
20078       return
20079       end function indmat
20080 !-----------------------------------------------------------------------------
20081       real(kind=8) function sigm(x)
20082 !el
20083        real(kind=8) :: x
20084       sigm=0.25d0*x
20085       return
20086       end function sigm
20087 !-----------------------------------------------------------------------------
20088 !-----------------------------------------------------------------------------
20089       subroutine alloc_ener_arrays
20090 !EL Allocation of arrays used by module energy
20091       use MD_data, only: mset
20092 !el local variables
20093       integer :: i,j
20094
20095       if(nres.lt.100) then
20096       maxconts=10*nres
20097       elseif(nres.lt.200) then
20098       maxconts=10*nres      ! Max. number of contacts per residue
20099       else
20100       maxconts=10*nres ! (maxconts=maxres/4)
20101       endif
20102       maxcont=12*nres      ! Max. number of SC contacts
20103       maxvar=6*nres      ! Max. number of variables
20104 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20105       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20106 !----------------------
20107 ! arrays in subroutine init_int_table
20108 !el#ifdef MPI
20109 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
20110 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
20111 !el#endif
20112       allocate(nint_gr(nres))
20113       allocate(nscp_gr(nres))
20114       allocate(ielstart(nres))
20115       allocate(ielend(nres))
20116 !(maxres)
20117       allocate(istart(nres,maxint_gr))
20118       allocate(iend(nres,maxint_gr))
20119 !(maxres,maxint_gr)
20120       allocate(iscpstart(nres,maxint_gr))
20121       allocate(iscpend(nres,maxint_gr))
20122 !(maxres,maxint_gr)
20123       allocate(ielstart_vdw(nres))
20124       allocate(ielend_vdw(nres))
20125 !(maxres)
20126       allocate(nint_gr_nucl(nres))
20127       allocate(nscp_gr_nucl(nres))
20128       allocate(ielstart_nucl(nres))
20129       allocate(ielend_nucl(nres))
20130 !(maxres)
20131       allocate(istart_nucl(nres,maxint_gr))
20132       allocate(iend_nucl(nres,maxint_gr))
20133 !(maxres,maxint_gr)
20134       allocate(iscpstart_nucl(nres,maxint_gr))
20135       allocate(iscpend_nucl(nres,maxint_gr))
20136 !(maxres,maxint_gr)
20137       allocate(ielstart_vdw_nucl(nres))
20138       allocate(ielend_vdw_nucl(nres))
20139
20140       allocate(lentyp(0:nfgtasks-1))
20141 !(0:maxprocs-1)
20142 !----------------------
20143 ! commom.contacts
20144 !      common /contacts/
20145       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
20146       allocate(icont(2,maxcont))
20147 !(2,maxcont)
20148 !      common /contacts1/
20149       allocate(num_cont(0:nres+4))
20150 !(maxres)
20151       allocate(jcont(maxconts,nres))
20152 !(maxconts,maxres)
20153       allocate(facont(maxconts,nres))
20154 !(maxconts,maxres)
20155       allocate(gacont(3,maxconts,nres))
20156 !(3,maxconts,maxres)
20157 !      common /contacts_hb/
20158       allocate(gacontp_hb1(3,maxconts,nres))
20159       allocate(gacontp_hb2(3,maxconts,nres))
20160       allocate(gacontp_hb3(3,maxconts,nres))
20161       allocate(gacontm_hb1(3,maxconts,nres))
20162       allocate(gacontm_hb2(3,maxconts,nres))
20163       allocate(gacontm_hb3(3,maxconts,nres))
20164       allocate(gacont_hbr(3,maxconts,nres))
20165       allocate(grij_hb_cont(3,maxconts,nres))
20166 !(3,maxconts,maxres)
20167       allocate(facont_hb(maxconts,nres))
20168
20169       allocate(ees0p(maxconts,nres))
20170       allocate(ees0m(maxconts,nres))
20171       allocate(d_cont(maxconts,nres))
20172       allocate(ees0plist(maxconts,nres))
20173
20174 !(maxconts,maxres)
20175       allocate(num_cont_hb(nres))
20176 !(maxres)
20177       allocate(jcont_hb(maxconts,nres))
20178 !(maxconts,maxres)
20179 !      common /rotat/
20180       allocate(Ug(2,2,nres))
20181       allocate(Ugder(2,2,nres))
20182       allocate(Ug2(2,2,nres))
20183       allocate(Ug2der(2,2,nres))
20184 !(2,2,maxres)
20185       allocate(obrot(2,nres))
20186       allocate(obrot2(2,nres))
20187       allocate(obrot_der(2,nres))
20188       allocate(obrot2_der(2,nres))
20189 !(2,maxres)
20190 !      common /precomp1/
20191       allocate(mu(2,nres))
20192       allocate(muder(2,nres))
20193       allocate(Ub2(2,nres))
20194       Ub2(1,:)=0.0d0
20195       Ub2(2,:)=0.0d0
20196       allocate(Ub2der(2,nres))
20197       allocate(Ctobr(2,nres))
20198       allocate(Ctobrder(2,nres))
20199       allocate(Dtobr2(2,nres))
20200       allocate(Dtobr2der(2,nres))
20201 !(2,maxres)
20202       allocate(EUg(2,2,nres))
20203       allocate(EUgder(2,2,nres))
20204       allocate(CUg(2,2,nres))
20205       allocate(CUgder(2,2,nres))
20206       allocate(DUg(2,2,nres))
20207       allocate(Dugder(2,2,nres))
20208       allocate(DtUg2(2,2,nres))
20209       allocate(DtUg2der(2,2,nres))
20210 !(2,2,maxres)
20211 !      common /precomp2/
20212       allocate(Ug2Db1t(2,nres))
20213       allocate(Ug2Db1tder(2,nres))
20214       allocate(CUgb2(2,nres))
20215       allocate(CUgb2der(2,nres))
20216 !(2,maxres)
20217       allocate(EUgC(2,2,nres))
20218       allocate(EUgCder(2,2,nres))
20219       allocate(EUgD(2,2,nres))
20220       allocate(EUgDder(2,2,nres))
20221       allocate(DtUg2EUg(2,2,nres))
20222       allocate(Ug2DtEUg(2,2,nres))
20223 !(2,2,maxres)
20224       allocate(Ug2DtEUgder(2,2,2,nres))
20225       allocate(DtUg2EUgder(2,2,2,nres))
20226 !(2,2,2,maxres)
20227       allocate(b1(2,nres))      !(2,-maxtor:maxtor)
20228       allocate(b2(2,nres))      !(2,-maxtor:maxtor)
20229       allocate(b1tilde(2,nres)) !(2,-maxtor:maxtor)
20230       allocate(b2tilde(2,nres)) !(2,-maxtor:maxtor)
20231
20232       allocate(ctilde(2,2,nres))
20233       allocate(dtilde(2,2,nres)) !(2,2,-maxtor:maxtor)
20234       allocate(gtb1(2,nres))
20235       allocate(gtb2(2,nres))
20236       allocate(cc(2,2,nres))
20237       allocate(dd(2,2,nres))
20238       allocate(ee(2,2,nres))
20239       allocate(gtcc(2,2,nres))
20240       allocate(gtdd(2,2,nres))
20241       allocate(gtee(2,2,nres))
20242       allocate(gUb2(2,nres))
20243       allocate(gteUg(2,2,nres))
20244
20245 !      common /rotat_old/
20246       allocate(costab(nres))
20247       allocate(sintab(nres))
20248       allocate(costab2(nres))
20249       allocate(sintab2(nres))
20250 !(maxres)
20251 !      common /dipmat/
20252       allocate(a_chuj(2,2,maxconts,nres))
20253 !(2,2,maxconts,maxres)(maxconts=maxres/4)
20254       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
20255 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
20256 !      common /contdistrib/
20257       allocate(ncont_sent(nres))
20258       allocate(ncont_recv(nres))
20259
20260       allocate(iat_sent(nres))
20261 !(maxres)
20262       allocate(iint_sent(4,nres,nres))
20263       allocate(iint_sent_local(4,nres,nres))
20264 !(4,maxres,maxres)
20265       allocate(iturn3_sent(4,0:nres+4))
20266       allocate(iturn4_sent(4,0:nres+4))
20267       allocate(iturn3_sent_local(4,nres))
20268       allocate(iturn4_sent_local(4,nres))
20269 !(4,maxres)
20270       allocate(itask_cont_from(0:nfgtasks-1))
20271       allocate(itask_cont_to(0:nfgtasks-1))
20272 !(0:max_fg_procs-1)
20273
20274
20275
20276 !----------------------
20277 ! commom.deriv;
20278 !      common /derivat/
20279       allocate(dcdv(6,maxdim))
20280       allocate(dxdv(6,maxdim))
20281 !(6,maxdim)
20282       allocate(dxds(6,nres))
20283 !(6,maxres)
20284       allocate(gradx(3,-1:nres,0:2))
20285       allocate(gradc(3,-1:nres,0:2))
20286 !(3,maxres,2)
20287       allocate(gvdwx(3,-1:nres))
20288       allocate(gvdwc(3,-1:nres))
20289       allocate(gelc(3,-1:nres))
20290       allocate(gelc_long(3,-1:nres))
20291       allocate(gvdwpp(3,-1:nres))
20292       allocate(gvdwc_scpp(3,-1:nres))
20293       allocate(gradx_scp(3,-1:nres))
20294       allocate(gvdwc_scp(3,-1:nres))
20295       allocate(ghpbx(3,-1:nres))
20296       allocate(ghpbc(3,-1:nres))
20297       allocate(gradcorr(3,-1:nres))
20298       allocate(gradcorr_long(3,-1:nres))
20299       allocate(gradcorr5_long(3,-1:nres))
20300       allocate(gradcorr6_long(3,-1:nres))
20301       allocate(gcorr6_turn_long(3,-1:nres))
20302       allocate(gradxorr(3,-1:nres))
20303       allocate(gradcorr5(3,-1:nres))
20304       allocate(gradcorr6(3,-1:nres))
20305       allocate(gliptran(3,-1:nres))
20306       allocate(gliptranc(3,-1:nres))
20307       allocate(gliptranx(3,-1:nres))
20308       allocate(gshieldx(3,-1:nres))
20309       allocate(gshieldc(3,-1:nres))
20310       allocate(gshieldc_loc(3,-1:nres))
20311       allocate(gshieldx_ec(3,-1:nres))
20312       allocate(gshieldc_ec(3,-1:nres))
20313       allocate(gshieldc_loc_ec(3,-1:nres))
20314       allocate(gshieldx_t3(3,-1:nres))
20315       allocate(gshieldc_t3(3,-1:nres))
20316       allocate(gshieldc_loc_t3(3,-1:nres))
20317       allocate(gshieldx_t4(3,-1:nres))
20318       allocate(gshieldc_t4(3,-1:nres))
20319       allocate(gshieldc_loc_t4(3,-1:nres))
20320       allocate(gshieldx_ll(3,-1:nres))
20321       allocate(gshieldc_ll(3,-1:nres))
20322       allocate(gshieldc_loc_ll(3,-1:nres))
20323       allocate(grad_shield(3,-1:nres))
20324       allocate(gg_tube_sc(3,-1:nres))
20325       allocate(gg_tube(3,-1:nres))
20326       allocate(gradafm(3,-1:nres))
20327       allocate(gradb_nucl(3,-1:nres))
20328       allocate(gradbx_nucl(3,-1:nres))
20329       allocate(gvdwpsb1(3,-1:nres))
20330       allocate(gelpp(3,-1:nres))
20331       allocate(gvdwpsb(3,-1:nres))
20332       allocate(gelsbc(3,-1:nres))
20333       allocate(gelsbx(3,-1:nres))
20334       allocate(gvdwsbx(3,-1:nres))
20335       allocate(gvdwsbc(3,-1:nres))
20336       allocate(gsbloc(3,-1:nres))
20337       allocate(gsblocx(3,-1:nres))
20338       allocate(gradcorr_nucl(3,-1:nres))
20339       allocate(gradxorr_nucl(3,-1:nres))
20340       allocate(gradcorr3_nucl(3,-1:nres))
20341       allocate(gradxorr3_nucl(3,-1:nres))
20342       allocate(gvdwpp_nucl(3,-1:nres))
20343       allocate(gradpepcat(3,-1:nres))
20344       allocate(gradpepcatx(3,-1:nres))
20345       allocate(gradcatcat(3,-1:nres))
20346 !(3,maxres)
20347       allocate(grad_shield_side(3,maxcontsshi,-1:nres))
20348       allocate(grad_shield_loc(3,maxcontsshi,-1:nres))
20349 ! grad for shielding surroing
20350       allocate(gloc(0:maxvar,0:2))
20351       allocate(gloc_x(0:maxvar,2))
20352 !(maxvar,2)
20353       allocate(gel_loc(3,-1:nres))
20354       allocate(gel_loc_long(3,-1:nres))
20355       allocate(gcorr3_turn(3,-1:nres))
20356       allocate(gcorr4_turn(3,-1:nres))
20357       allocate(gcorr6_turn(3,-1:nres))
20358       allocate(gradb(3,-1:nres))
20359       allocate(gradbx(3,-1:nres))
20360 !(3,maxres)
20361       allocate(gel_loc_loc(maxvar))
20362       allocate(gel_loc_turn3(maxvar))
20363       allocate(gel_loc_turn4(maxvar))
20364       allocate(gel_loc_turn6(maxvar))
20365       allocate(gcorr_loc(maxvar))
20366       allocate(g_corr5_loc(maxvar))
20367       allocate(g_corr6_loc(maxvar))
20368 !(maxvar)
20369       allocate(gsccorc(3,-1:nres))
20370       allocate(gsccorx(3,-1:nres))
20371 !(3,maxres)
20372       allocate(gsccor_loc(-1:nres))
20373 !(maxres)
20374       allocate(gvdwx_scbase(3,-1:nres))
20375       allocate(gvdwc_scbase(3,-1:nres))
20376       allocate(gvdwx_pepbase(3,-1:nres))
20377       allocate(gvdwc_pepbase(3,-1:nres))
20378       allocate(gvdwx_scpho(3,-1:nres))
20379       allocate(gvdwc_scpho(3,-1:nres))
20380       allocate(gvdwc_peppho(3,-1:nres))
20381
20382       allocate(dtheta(3,2,-1:nres))
20383 !(3,2,maxres)
20384       allocate(gscloc(3,-1:nres))
20385       allocate(gsclocx(3,-1:nres))
20386 !(3,maxres)
20387       allocate(dphi(3,3,-1:nres))
20388       allocate(dalpha(3,3,-1:nres))
20389       allocate(domega(3,3,-1:nres))
20390 !(3,3,maxres)
20391 !      common /deriv_scloc/
20392       allocate(dXX_C1tab(3,nres))
20393       allocate(dYY_C1tab(3,nres))
20394       allocate(dZZ_C1tab(3,nres))
20395       allocate(dXX_Ctab(3,nres))
20396       allocate(dYY_Ctab(3,nres))
20397       allocate(dZZ_Ctab(3,nres))
20398       allocate(dXX_XYZtab(3,nres))
20399       allocate(dYY_XYZtab(3,nres))
20400       allocate(dZZ_XYZtab(3,nres))
20401 !(3,maxres)
20402 !      common /mpgrad/
20403       allocate(jgrad_start(nres))
20404       allocate(jgrad_end(nres))
20405 !(maxres)
20406 !----------------------
20407
20408 !      common /indices/
20409       allocate(ibond_displ(0:nfgtasks-1))
20410       allocate(ibond_count(0:nfgtasks-1))
20411       allocate(ithet_displ(0:nfgtasks-1))
20412       allocate(ithet_count(0:nfgtasks-1))
20413       allocate(iphi_displ(0:nfgtasks-1))
20414       allocate(iphi_count(0:nfgtasks-1))
20415       allocate(iphi1_displ(0:nfgtasks-1))
20416       allocate(iphi1_count(0:nfgtasks-1))
20417       allocate(ivec_displ(0:nfgtasks-1))
20418       allocate(ivec_count(0:nfgtasks-1))
20419       allocate(iset_displ(0:nfgtasks-1))
20420       allocate(iset_count(0:nfgtasks-1))
20421       allocate(iint_count(0:nfgtasks-1))
20422       allocate(iint_displ(0:nfgtasks-1))
20423 !(0:max_fg_procs-1)
20424 !----------------------
20425 ! common.MD
20426 !      common /mdgrad/
20427       allocate(gcart(3,-1:nres))
20428       allocate(gxcart(3,-1:nres))
20429 !(3,0:MAXRES)
20430       allocate(gradcag(3,-1:nres))
20431       allocate(gradxag(3,-1:nres))
20432 !(3,MAXRES)
20433 !      common /back_constr/
20434 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
20435       allocate(dutheta(nres))
20436       allocate(dugamma(nres))
20437 !(maxres)
20438       allocate(duscdiff(3,nres))
20439       allocate(duscdiffx(3,nres))
20440 !(3,maxres)
20441 !el i io:read_fragments
20442 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
20443 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
20444 !      common /qmeas/
20445 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
20446 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
20447       allocate(mset(0:nprocs))  !(maxprocs/20)
20448       mset(:)=0
20449 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
20450 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
20451       allocate(dUdconst(3,0:nres))
20452       allocate(dUdxconst(3,0:nres))
20453       allocate(dqwol(3,0:nres))
20454       allocate(dxqwol(3,0:nres))
20455 !(3,0:MAXRES)
20456 !----------------------
20457 ! common.sbridge
20458 !      common /sbridge/ in io_common: read_bridge
20459 !el    allocate((:),allocatable :: iss      !(maxss)
20460 !      common /links/  in io_common: read_bridge
20461 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
20462 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
20463 !      common /dyn_ssbond/
20464 ! and side-chain vectors in theta or phi.
20465       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
20466 !(maxres,maxres)
20467 !      do i=1,nres
20468 !        do j=i+1,nres
20469       dyn_ssbond_ij(:,:)=1.0d300
20470 !        enddo
20471 !      enddo
20472
20473 !      if (nss.gt.0) then
20474       allocate(idssb(maxdim),jdssb(maxdim))
20475 !        allocate(newihpb(nss),newjhpb(nss))
20476 !(maxdim)
20477 !      endif
20478       allocate(ishield_list(-1:nres))
20479       allocate(shield_list(maxcontsshi,-1:nres))
20480       allocate(dyn_ss_mask(nres))
20481       allocate(fac_shield(-1:nres))
20482       allocate(enetube(nres*2))
20483       allocate(enecavtube(nres*2))
20484
20485 !(maxres)
20486       dyn_ss_mask(:)=.false.
20487 !----------------------
20488 ! common.sccor
20489 ! Parameters of the SCCOR term
20490 !      common/sccor/
20491 !el in io_conf: parmread
20492 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
20493 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
20494 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
20495 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
20496 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
20497 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
20498 !      allocate(vlor1sccor(maxterm_sccor,20,20))
20499 !      allocate(vlor2sccor(maxterm_sccor,20,20))
20500 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
20501 !----------------
20502       allocate(gloc_sc(3,0:2*nres,0:10))
20503 !(3,0:maxres2,10)maxres2=2*maxres
20504       allocate(dcostau(3,3,3,2*nres))
20505       allocate(dsintau(3,3,3,2*nres))
20506       allocate(dtauangle(3,3,3,2*nres))
20507       allocate(dcosomicron(3,3,3,2*nres))
20508       allocate(domicron(3,3,3,2*nres))
20509 !(3,3,3,maxres2)maxres2=2*maxres
20510 !----------------------
20511 ! common.var
20512 !      common /restr/
20513       allocate(varall(maxvar))
20514 !(maxvar)(maxvar=6*maxres)
20515       allocate(mask_theta(nres))
20516       allocate(mask_phi(nres))
20517       allocate(mask_side(nres))
20518 !(maxres)
20519 !----------------------
20520 ! common.vectors
20521 !      common /vectors/
20522       allocate(uy(3,nres))
20523       allocate(uz(3,nres))
20524 !(3,maxres)
20525       allocate(uygrad(3,3,2,nres))
20526       allocate(uzgrad(3,3,2,nres))
20527 !(3,3,2,maxres)
20528 ! allocateion of lists JPRDLA
20529       allocate(newcontlistppi(300*nres))
20530       allocate(newcontlistscpi(300*nres))
20531       allocate(newcontlisti(300*nres))
20532       allocate(newcontlistppj(300*nres))
20533       allocate(newcontlistscpj(300*nres))
20534       allocate(newcontlistj(300*nres))
20535
20536       return
20537       end subroutine alloc_ener_arrays
20538 !-----------------------------------------------------------------
20539       subroutine ebond_nucl(estr_nucl)
20540 !c
20541 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
20542 !c
20543
20544       real(kind=8),dimension(3) :: u,ud
20545       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
20546       real(kind=8) :: estr_nucl,diff
20547       integer :: iti,i,j,k,nbi
20548       estr_nucl=0.0d0
20549 !C      print *,"I enter ebond"
20550       if (energy_dec) &
20551       write (iout,*) "ibondp_start,ibondp_end",&
20552        ibondp_nucl_start,ibondp_nucl_end
20553       do i=ibondp_nucl_start,ibondp_nucl_end
20554       if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
20555        itype(i,2).eq.ntyp1_molec(2)) cycle
20556 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
20557 !          do j=1,3
20558 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
20559 !     &      *dc(j,i-1)/vbld(i)
20560 !          enddo
20561 !          if (energy_dec) write(iout,*)
20562 !     &       "estr1",i,vbld(i),distchainmax,
20563 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
20564
20565         diff = vbld(i)-vbldp0_nucl
20566         if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
20567         vbldp0_nucl,diff,AKP_nucl*diff*diff
20568         estr_nucl=estr_nucl+diff*diff
20569 !          print *,estr_nucl
20570         do j=1,3
20571           gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
20572         enddo
20573 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
20574       enddo
20575       estr_nucl=0.5d0*AKP_nucl*estr_nucl
20576 !      print *,"partial sum", estr_nucl,AKP_nucl
20577
20578       if (energy_dec) &
20579       write (iout,*) "ibondp_start,ibondp_end",&
20580        ibond_nucl_start,ibond_nucl_end
20581
20582       do i=ibond_nucl_start,ibond_nucl_end
20583 !C        print *, "I am stuck",i
20584       iti=itype(i,2)
20585       if (iti.eq.ntyp1_molec(2)) cycle
20586         nbi=nbondterm_nucl(iti)
20587 !C        print *,iti,nbi
20588         if (nbi.eq.1) then
20589           diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
20590
20591           if (energy_dec) &
20592          write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
20593          AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
20594           estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
20595 !            print *,estr_nucl
20596           do j=1,3
20597             gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
20598           enddo
20599         else
20600           do j=1,nbi
20601             diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
20602             ud(j)=aksc_nucl(j,iti)*diff
20603             u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
20604           enddo
20605           uprod=u(1)
20606           do j=2,nbi
20607             uprod=uprod*u(j)
20608           enddo
20609           usum=0.0d0
20610           usumsqder=0.0d0
20611           do j=1,nbi
20612             uprod1=1.0d0
20613             uprod2=1.0d0
20614             do k=1,nbi
20615             if (k.ne.j) then
20616               uprod1=uprod1*u(k)
20617               uprod2=uprod2*u(k)*u(k)
20618             endif
20619             enddo
20620             usum=usum+uprod1
20621             usumsqder=usumsqder+ud(j)*uprod2
20622           enddo
20623           estr_nucl=estr_nucl+uprod/usum
20624           do j=1,3
20625            gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
20626           enddo
20627       endif
20628       enddo
20629 !C      print *,"I am about to leave ebond"
20630       return
20631       end subroutine ebond_nucl
20632
20633 !-----------------------------------------------------------------------------
20634       subroutine ebend_nucl(etheta_nucl)
20635       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
20636       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
20637       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
20638       logical :: lprn=.false., lprn1=.false.
20639 !el local variables
20640       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
20641       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
20642       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
20643 ! local variables for constrains
20644       real(kind=8) :: difi,thetiii
20645        integer itheta
20646       etheta_nucl=0.0D0
20647 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
20648       do i=ithet_nucl_start,ithet_nucl_end
20649       if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
20650       (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
20651       (itype(i,2).eq.ntyp1_molec(2))) cycle
20652       dethetai=0.0d0
20653       dephii=0.0d0
20654       dephii1=0.0d0
20655       theti2=0.5d0*theta(i)
20656       ityp2=ithetyp_nucl(itype(i-1,2))
20657       do k=1,nntheterm_nucl
20658         coskt(k)=dcos(k*theti2)
20659         sinkt(k)=dsin(k*theti2)
20660       enddo
20661       if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
20662 #ifdef OSF
20663         phii=phi(i)
20664         if (phii.ne.phii) phii=150.0
20665 #else
20666         phii=phi(i)
20667 #endif
20668         ityp1=ithetyp_nucl(itype(i-2,2))
20669         do k=1,nsingle_nucl
20670           cosph1(k)=dcos(k*phii)
20671           sinph1(k)=dsin(k*phii)
20672         enddo
20673       else
20674         phii=0.0d0
20675         ityp1=nthetyp_nucl+1
20676         do k=1,nsingle_nucl
20677           cosph1(k)=0.0d0
20678           sinph1(k)=0.0d0
20679         enddo
20680       endif
20681
20682       if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
20683 #ifdef OSF
20684         phii1=phi(i+1)
20685         if (phii1.ne.phii1) phii1=150.0
20686         phii1=pinorm(phii1)
20687 #else
20688         phii1=phi(i+1)
20689 #endif
20690         ityp3=ithetyp_nucl(itype(i,2))
20691         do k=1,nsingle_nucl
20692           cosph2(k)=dcos(k*phii1)
20693           sinph2(k)=dsin(k*phii1)
20694         enddo
20695       else
20696         phii1=0.0d0
20697         ityp3=nthetyp_nucl+1
20698         do k=1,nsingle_nucl
20699           cosph2(k)=0.0d0
20700           sinph2(k)=0.0d0
20701         enddo
20702       endif
20703       ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
20704       do k=1,ndouble_nucl
20705         do l=1,k-1
20706           ccl=cosph1(l)*cosph2(k-l)
20707           ssl=sinph1(l)*sinph2(k-l)
20708           scl=sinph1(l)*cosph2(k-l)
20709           csl=cosph1(l)*sinph2(k-l)
20710           cosph1ph2(l,k)=ccl-ssl
20711           cosph1ph2(k,l)=ccl+ssl
20712           sinph1ph2(l,k)=scl+csl
20713           sinph1ph2(k,l)=scl-csl
20714         enddo
20715       enddo
20716       if (lprn) then
20717       write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
20718        " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
20719       write (iout,*) "coskt and sinkt",nntheterm_nucl
20720       do k=1,nntheterm_nucl
20721         write (iout,*) k,coskt(k),sinkt(k)
20722       enddo
20723       endif
20724       do k=1,ntheterm_nucl
20725         ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
20726         dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
20727          *coskt(k)
20728         if (lprn)&
20729        write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
20730         " ethetai",ethetai
20731       enddo
20732       if (lprn) then
20733       write (iout,*) "cosph and sinph"
20734       do k=1,nsingle_nucl
20735         write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
20736       enddo
20737       write (iout,*) "cosph1ph2 and sinph2ph2"
20738       do k=2,ndouble_nucl
20739         do l=1,k-1
20740           write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
20741             sinph1ph2(l,k),sinph1ph2(k,l)
20742         enddo
20743       enddo
20744       write(iout,*) "ethetai",ethetai
20745       endif
20746       do m=1,ntheterm2_nucl
20747         do k=1,nsingle_nucl
20748           aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
20749             +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
20750             +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
20751             +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
20752           ethetai=ethetai+sinkt(m)*aux
20753           dethetai=dethetai+0.5d0*m*aux*coskt(m)
20754           dephii=dephii+k*sinkt(m)*(&
20755              ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
20756              bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
20757           dephii1=dephii1+k*sinkt(m)*(&
20758              eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
20759              ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
20760           if (lprn) &
20761          write (iout,*) "m",m," k",k," bbthet",&
20762             bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
20763             ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
20764             ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
20765             eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20766         enddo
20767       enddo
20768       if (lprn) &
20769       write(iout,*) "ethetai",ethetai
20770       do m=1,ntheterm3_nucl
20771         do k=2,ndouble_nucl
20772           do l=1,k-1
20773             aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20774              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
20775              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20776              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
20777             ethetai=ethetai+sinkt(m)*aux
20778             dethetai=dethetai+0.5d0*m*coskt(m)*aux
20779             dephii=dephii+l*sinkt(m)*(&
20780             -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
20781              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20782              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20783              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20784             dephii1=dephii1+(k-l)*sinkt(m)*( &
20785             -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20786              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20787              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
20788              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20789             if (lprn) then
20790             write (iout,*) "m",m," k",k," l",l," ffthet", &
20791              ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
20792              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
20793              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
20794              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20795             write (iout,*) cosph1ph2(l,k)*sinkt(m), &
20796              cosph1ph2(k,l)*sinkt(m),&
20797              sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
20798             endif
20799           enddo
20800         enddo
20801       enddo
20802 10      continue
20803       if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
20804       i,theta(i)*rad2deg,phii*rad2deg, &
20805       phii1*rad2deg,ethetai
20806       etheta_nucl=etheta_nucl+ethetai
20807 !        print *,i,"partial sum",etheta_nucl
20808       if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
20809       if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
20810       gloc(nphi+i-2,icg)=wang_nucl*dethetai
20811       enddo
20812       return
20813       end subroutine ebend_nucl
20814 !----------------------------------------------------
20815       subroutine etor_nucl(etors_nucl)
20816 !      implicit real*8 (a-h,o-z)
20817 !      include 'DIMENSIONS'
20818 !      include 'COMMON.VAR'
20819 !      include 'COMMON.GEO'
20820 !      include 'COMMON.LOCAL'
20821 !      include 'COMMON.TORSION'
20822 !      include 'COMMON.INTERACT'
20823 !      include 'COMMON.DERIV'
20824 !      include 'COMMON.CHAIN'
20825 !      include 'COMMON.NAMES'
20826 !      include 'COMMON.IOUNITS'
20827 !      include 'COMMON.FFIELD'
20828 !      include 'COMMON.TORCNSTR'
20829 !      include 'COMMON.CONTROL'
20830       real(kind=8) :: etors_nucl,edihcnstr
20831       logical :: lprn
20832 !el local variables
20833       integer :: i,j,iblock,itori,itori1
20834       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
20835                vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
20836 ! Set lprn=.true. for debugging
20837       lprn=.false.
20838 !     lprn=.true.
20839       etors_nucl=0.0D0
20840 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
20841       do i=iphi_nucl_start,iphi_nucl_end
20842       if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
20843            .or. itype(i-3,2).eq.ntyp1_molec(2) &
20844            .or. itype(i,2).eq.ntyp1_molec(2)) cycle
20845       etors_ii=0.0D0
20846       itori=itortyp_nucl(itype(i-2,2))
20847       itori1=itortyp_nucl(itype(i-1,2))
20848       phii=phi(i)
20849 !         print *,i,itori,itori1
20850       gloci=0.0D0
20851 !C Regular cosine and sine terms
20852       do j=1,nterm_nucl(itori,itori1)
20853         v1ij=v1_nucl(j,itori,itori1)
20854         v2ij=v2_nucl(j,itori,itori1)
20855         cosphi=dcos(j*phii)
20856         sinphi=dsin(j*phii)
20857         etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
20858         if (energy_dec) etors_ii=etors_ii+&
20859                  v1ij*cosphi+v2ij*sinphi
20860         gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
20861       enddo
20862 !C Lorentz terms
20863 !C                         v1
20864 !C  E = SUM ----------------------------------- - v1
20865 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
20866 !C
20867       cosphi=dcos(0.5d0*phii)
20868       sinphi=dsin(0.5d0*phii)
20869       do j=1,nlor_nucl(itori,itori1)
20870         vl1ij=vlor1_nucl(j,itori,itori1)
20871         vl2ij=vlor2_nucl(j,itori,itori1)
20872         vl3ij=vlor3_nucl(j,itori,itori1)
20873         pom=vl2ij*cosphi+vl3ij*sinphi
20874         pom1=1.0d0/(pom*pom+1.0d0)
20875         etors_nucl=etors_nucl+vl1ij*pom1
20876         if (energy_dec) etors_ii=etors_ii+ &
20877                  vl1ij*pom1
20878         pom=-pom*pom1*pom1
20879         gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
20880       enddo
20881 !C Subtract the constant term
20882       etors_nucl=etors_nucl-v0_nucl(itori,itori1)
20883         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
20884             'etor',i,etors_ii-v0_nucl(itori,itori1)
20885       if (lprn) &
20886        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
20887        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
20888        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
20889       gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
20890 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
20891       enddo
20892       return
20893       end subroutine etor_nucl
20894 !------------------------------------------------------------
20895       subroutine epp_nucl_sub(evdw1,ees)
20896 !C
20897 !C This subroutine calculates the average interaction energy and its gradient
20898 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
20899 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
20900 !C The potential depends both on the distance of peptide-group centers and on
20901 !C the orientation of the CA-CA virtual bonds.
20902 !C
20903       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
20904       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbbi,sslipi,ssgradlipi, &
20905                       sslipj,ssgradlipj,faclipij2
20906       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
20907              dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
20908              dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
20909       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20910                 dist_temp, dist_init,sss_grad,fac,evdw1ij
20911       integer xshift,yshift,zshift
20912       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
20913       real(kind=8) :: ees,eesij
20914 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20915       real(kind=8) scal_el /0.5d0/
20916       t_eelecij=0.0d0
20917       ees=0.0D0
20918       evdw1=0.0D0
20919       ind=0
20920 !c
20921 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
20922 !c
20923 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
20924       do i=iatel_s_nucl,iatel_e_nucl
20925       if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20926       dxi=dc(1,i)
20927       dyi=dc(2,i)
20928       dzi=dc(3,i)
20929       dx_normi=dc_norm(1,i)
20930       dy_normi=dc_norm(2,i)
20931       dz_normi=dc_norm(3,i)
20932       xmedi=c(1,i)+0.5d0*dxi
20933       ymedi=c(2,i)+0.5d0*dyi
20934       zmedi=c(3,i)+0.5d0*dzi
20935         call to_box(xmedi,ymedi,zmedi)
20936         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
20937
20938       do j=ielstart_nucl(i),ielend_nucl(i)
20939         if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
20940         ind=ind+1
20941         dxj=dc(1,j)
20942         dyj=dc(2,j)
20943         dzj=dc(3,j)
20944 !          xj=c(1,j)+0.5D0*dxj-xmedi
20945 !          yj=c(2,j)+0.5D0*dyj-ymedi
20946 !          zj=c(3,j)+0.5D0*dzj-zmedi
20947         xj=c(1,j)+0.5D0*dxj
20948         yj=c(2,j)+0.5D0*dyj
20949         zj=c(3,j)+0.5D0*dzj
20950      call to_box(xj,yj,zj)
20951      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
20952       faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
20953       xj=boxshift(xj-xmedi,boxxsize)
20954       yj=boxshift(yj-ymedi,boxysize)
20955       zj=boxshift(zj-zmedi,boxzsize)
20956         rij=xj*xj+yj*yj+zj*zj
20957 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
20958         fac=(r0pp**2/rij)**3
20959         ev1=epspp*fac*fac
20960         ev2=epspp*fac
20961         evdw1ij=ev1-2*ev2
20962         fac=(-ev1-evdw1ij)/rij
20963 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
20964         if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
20965         evdw1=evdw1+evdw1ij
20966 !C
20967 !C Calculate contributions to the Cartesian gradient.
20968 !C
20969         ggg(1)=fac*xj
20970         ggg(2)=fac*yj
20971         ggg(3)=fac*zj
20972         do k=1,3
20973           gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
20974           gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
20975         enddo
20976 !c phoshate-phosphate electrostatic interactions
20977         rij=dsqrt(rij)
20978         fac=1.0d0/rij
20979         eesij=dexp(-BEES*rij)*fac
20980 !          write (2,*)"fac",fac," eesijpp",eesij
20981         if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
20982         ees=ees+eesij
20983 !c          fac=-eesij*fac
20984         fac=-(fac+BEES)*eesij*fac
20985         ggg(1)=fac*xj
20986         ggg(2)=fac*yj
20987         ggg(3)=fac*zj
20988 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
20989 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
20990 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
20991         do k=1,3
20992           gelpp(k,i)=gelpp(k,i)-ggg(k)
20993           gelpp(k,j)=gelpp(k,j)+ggg(k)
20994         enddo
20995       enddo ! j
20996       enddo   ! i
20997 !c      ees=332.0d0*ees
20998       ees=AEES*ees
20999       do i=nnt,nct
21000 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21001       do k=1,3
21002         gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
21003 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
21004         gelpp(k,i)=AEES*gelpp(k,i)
21005       enddo
21006 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21007       enddo
21008 !c      write (2,*) "total EES",ees
21009       return
21010       end subroutine epp_nucl_sub
21011 !---------------------------------------------------------------------
21012       subroutine epsb(evdwpsb,eelpsb)
21013 !      use comm_locel
21014 !C
21015 !C This subroutine calculates the excluded-volume interaction energy between
21016 !C peptide-group centers and side chains and its gradient in virtual-bond and
21017 !C side-chain vectors.
21018 !C
21019       real(kind=8),dimension(3):: ggg
21020       integer :: i,iint,j,k,iteli,itypj,subchap
21021       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
21022                e1,e2,evdwij,rij,evdwpsb,eelpsb
21023       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21024                 dist_temp, dist_init
21025       integer xshift,yshift,zshift
21026
21027 !cd    print '(a)','Enter ESCP'
21028 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
21029       eelpsb=0.0d0
21030       evdwpsb=0.0d0
21031 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
21032       do i=iatscp_s_nucl,iatscp_e_nucl
21033       if (itype(i,2).eq.ntyp1_molec(2) &
21034        .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21035       xi=0.5D0*(c(1,i)+c(1,i+1))
21036       yi=0.5D0*(c(2,i)+c(2,i+1))
21037       zi=0.5D0*(c(3,i)+c(3,i+1))
21038         call to_box(xi,yi,zi)
21039
21040       do iint=1,nscp_gr_nucl(i)
21041
21042       do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
21043         itypj=itype(j,2)
21044         if (itypj.eq.ntyp1_molec(2)) cycle
21045 !C Uncomment following three lines for SC-p interactions
21046 !c         xj=c(1,nres+j)-xi
21047 !c         yj=c(2,nres+j)-yi
21048 !c         zj=c(3,nres+j)-zi
21049 !C Uncomment following three lines for Ca-p interactions
21050 !          xj=c(1,j)-xi
21051 !          yj=c(2,j)-yi
21052 !          zj=c(3,j)-zi
21053         xj=c(1,j)
21054         yj=c(2,j)
21055         zj=c(3,j)
21056         call to_box(xj,yj,zj)
21057       xj=boxshift(xj-xi,boxxsize)
21058       yj=boxshift(yj-yi,boxysize)
21059       zj=boxshift(zj-zi,boxzsize)
21060
21061       dist_init=xj**2+yj**2+zj**2
21062
21063         rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21064         fac=rrij**expon2
21065         e1=fac*fac*aad_nucl(itypj)
21066         e2=fac*bad_nucl(itypj)
21067         if (iabs(j-i) .le. 2) then
21068           e1=scal14*e1
21069           e2=scal14*e2
21070         endif
21071         evdwij=e1+e2
21072         evdwpsb=evdwpsb+evdwij
21073         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
21074            'evdw2',i,j,evdwij,"tu4"
21075 !C
21076 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
21077 !C
21078         fac=-(evdwij+e1)*rrij
21079         ggg(1)=xj*fac
21080         ggg(2)=yj*fac
21081         ggg(3)=zj*fac
21082         do k=1,3
21083           gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
21084           gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
21085         enddo
21086       enddo
21087
21088       enddo ! iint
21089       enddo ! i
21090       do i=1,nct
21091       do j=1,3
21092         gvdwpsb(j,i)=expon*gvdwpsb(j,i)
21093         gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
21094       enddo
21095       enddo
21096       return
21097       end subroutine epsb
21098
21099 !------------------------------------------------------
21100       subroutine esb_gb(evdwsb,eelsb)
21101       use comm_locel
21102       use calc_data_nucl
21103       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
21104       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
21105       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
21106       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21107                 dist_temp, dist_init,aa,bb,faclip,sig0ij
21108       integer :: ii
21109       logical lprn
21110       evdw=0.0D0
21111       eelsb=0.0d0
21112       ecorr=0.0d0
21113       evdwsb=0.0D0
21114       lprn=.false.
21115       ind=0
21116 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
21117       do i=iatsc_s_nucl,iatsc_e_nucl
21118       num_conti=0
21119       num_conti2=0
21120       itypi=itype(i,2)
21121 !        PRINT *,"I=",i,itypi
21122       if (itypi.eq.ntyp1_molec(2)) cycle
21123       itypi1=itype(i+1,2)
21124       xi=c(1,nres+i)
21125       yi=c(2,nres+i)
21126       zi=c(3,nres+i)
21127       call to_box(xi,yi,zi)
21128       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
21129       dxi=dc_norm(1,nres+i)
21130       dyi=dc_norm(2,nres+i)
21131       dzi=dc_norm(3,nres+i)
21132       dsci_inv=vbld_inv(i+nres)
21133 !C
21134 !C Calculate SC interaction energy.
21135 !C
21136       do iint=1,nint_gr_nucl(i)
21137 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
21138         do j=istart_nucl(i,iint),iend_nucl(i,iint)
21139           ind=ind+1
21140 !            print *,"JESTEM"
21141           itypj=itype(j,2)
21142           if (itypj.eq.ntyp1_molec(2)) cycle
21143           dscj_inv=vbld_inv(j+nres)
21144           sig0ij=sigma_nucl(itypi,itypj)
21145           chi1=chi_nucl(itypi,itypj)
21146           chi2=chi_nucl(itypj,itypi)
21147           chi12=chi1*chi2
21148           chip1=chip_nucl(itypi,itypj)
21149           chip2=chip_nucl(itypj,itypi)
21150           chip12=chip1*chip2
21151 !            xj=c(1,nres+j)-xi
21152 !            yj=c(2,nres+j)-yi
21153 !            zj=c(3,nres+j)-zi
21154          xj=c(1,nres+j)
21155          yj=c(2,nres+j)
21156          zj=c(3,nres+j)
21157      call to_box(xj,yj,zj)
21158      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
21159       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
21160        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
21161       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
21162        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
21163       xj=boxshift(xj-xi,boxxsize)
21164       yj=boxshift(yj-yi,boxysize)
21165       zj=boxshift(zj-zi,boxzsize)
21166
21167           dxj=dc_norm(1,nres+j)
21168           dyj=dc_norm(2,nres+j)
21169           dzj=dc_norm(3,nres+j)
21170           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21171           rij=dsqrt(rrij)
21172 !C Calculate angle-dependent terms of energy and contributions to their
21173 !C derivatives.
21174           erij(1)=xj*rij
21175           erij(2)=yj*rij
21176           erij(3)=zj*rij
21177           om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
21178           om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
21179           om12=dxi*dxj+dyi*dyj+dzi*dzj
21180           call sc_angular_nucl
21181           sigsq=1.0D0/sigsq
21182           sig=sig0ij*dsqrt(sigsq)
21183           rij_shift=1.0D0/rij-sig+sig0ij
21184 !            print *,rij_shift,"rij_shift"
21185 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
21186 !c     &       " rij_shift",rij_shift
21187           if (rij_shift.le.0.0D0) then
21188             evdw=1.0D20
21189             return
21190           endif
21191           sigder=-sig*sigsq
21192 !c---------------------------------------------------------------
21193           rij_shift=1.0D0/rij_shift
21194           fac=rij_shift**expon
21195           e1=fac*fac*aa_nucl(itypi,itypj)
21196           e2=fac*bb_nucl(itypi,itypj)
21197           evdwij=eps1*eps2rt*(e1+e2)
21198 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
21199 !c     &       " e1",e1," e2",e2," evdwij",evdwij
21200           eps2der=evdwij
21201           evdwij=evdwij*eps2rt
21202           evdwsb=evdwsb+evdwij
21203           if (lprn) then
21204           sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
21205           epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
21206           write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
21207            restyp(itypi,2),i,restyp(itypj,2),j, &
21208            epsi,sigm,chi1,chi2,chip1,chip2, &
21209            eps1,eps2rt**2,sig,sig0ij, &
21210            om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
21211           evdwij
21212           write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
21213           endif
21214
21215           if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
21216                        'evdw',i,j,evdwij,"tu3"
21217
21218
21219 !C Calculate gradient components.
21220           e1=e1*eps1*eps2rt**2
21221           fac=-expon*(e1+evdwij)*rij_shift
21222           sigder=fac*sigder
21223           fac=rij*fac
21224 !c            fac=0.0d0
21225 !C Calculate the radial part of the gradient
21226           gg(1)=xj*fac
21227           gg(2)=yj*fac
21228           gg(3)=zj*fac
21229 !C Calculate angular part of the gradient.
21230           call sc_grad_nucl
21231           call eelsbij(eelij,num_conti2)
21232           if (energy_dec .and. &
21233          (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
21234         write (istat,'(e14.5)') evdwij
21235           eelsb=eelsb+eelij
21236         enddo      ! j
21237       enddo        ! iint
21238       num_cont_hb(i)=num_conti2
21239       enddo          ! i
21240 !c      write (iout,*) "Number of loop steps in EGB:",ind
21241 !cccc      energy_dec=.false.
21242       return
21243       end subroutine esb_gb
21244 !-------------------------------------------------------------------------------
21245       subroutine eelsbij(eesij,num_conti2)
21246       use comm_locel
21247       use calc_data_nucl
21248       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
21249       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
21250       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21251                 dist_temp, dist_init,rlocshield,fracinbuf
21252       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
21253
21254 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21255       real(kind=8) scal_el /0.5d0/
21256       integer :: iteli,itelj,kkk,kkll,m,isubchap
21257       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
21258       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
21259       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
21260               r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
21261               el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
21262               ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
21263               a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
21264               ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
21265               ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
21266               ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
21267       ind=ind+1
21268       itypi=itype(i,2)
21269       itypj=itype(j,2)
21270 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
21271       ael6i=ael6_nucl(itypi,itypj)
21272       ael3i=ael3_nucl(itypi,itypj)
21273       ael63i=ael63_nucl(itypi,itypj)
21274       ael32i=ael32_nucl(itypi,itypj)
21275 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
21276 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
21277       dxj=dc(1,j+nres)
21278       dyj=dc(2,j+nres)
21279       dzj=dc(3,j+nres)
21280       dx_normi=dc_norm(1,i+nres)
21281       dy_normi=dc_norm(2,i+nres)
21282       dz_normi=dc_norm(3,i+nres)
21283       dx_normj=dc_norm(1,j+nres)
21284       dy_normj=dc_norm(2,j+nres)
21285       dz_normj=dc_norm(3,j+nres)
21286 !c      xj=c(1,j)+0.5D0*dxj-xmedi
21287 !c      yj=c(2,j)+0.5D0*dyj-ymedi
21288 !c      zj=c(3,j)+0.5D0*dzj-zmedi
21289       if (ipot_nucl.ne.2) then
21290       cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
21291       cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
21292       cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
21293       else
21294       cosa=om12
21295       cosb=om1
21296       cosg=om2
21297       endif
21298       r3ij=rij*rrij
21299       r6ij=r3ij*r3ij
21300       fac=cosa-3.0D0*cosb*cosg
21301       facfac=fac*fac
21302       fac1=3.0d0*(cosb*cosb+cosg*cosg)
21303       fac3=ael6i*r6ij
21304       fac4=ael3i*r3ij
21305       fac5=ael63i*r6ij
21306       fac6=ael32i*r6ij
21307 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
21308 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
21309       el1=fac3*(4.0D0+facfac-fac1)
21310       el2=fac4*fac
21311       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
21312       el4=fac6*facfac
21313       eesij=el1+el2+el3+el4
21314 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
21315       ees0ij=4.0D0+facfac-fac1
21316
21317       if (energy_dec) then
21318         if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
21319         write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
21320          sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
21321          restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
21322          (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
21323         write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
21324       endif
21325
21326 !C
21327 !C Calculate contributions to the Cartesian gradient.
21328 !C
21329       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
21330       fac1=fac
21331 !c      erij(1)=xj*rmij
21332 !c      erij(2)=yj*rmij
21333 !c      erij(3)=zj*rmij
21334 !*
21335 !* Radial derivatives. First process both termini of the fragment (i,j)
21336 !*
21337       ggg(1)=facel*xj
21338       ggg(2)=facel*yj
21339       ggg(3)=facel*zj
21340       do k=1,3
21341       gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21342       gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21343       gelsbx(k,j)=gelsbx(k,j)+ggg(k)
21344       gelsbx(k,i)=gelsbx(k,i)-ggg(k)
21345       enddo
21346 !*
21347 !* Angular part
21348 !*
21349       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
21350       fac4=-3.0D0*fac4
21351       fac3=-6.0D0*fac3
21352       fac5= 6.0d0*fac5
21353       fac6=-6.0d0*fac6
21354       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
21355        fac6*fac1*cosg
21356       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
21357        fac6*fac1*cosb
21358       do k=1,3
21359       dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
21360       dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
21361       enddo
21362       do k=1,3
21363       ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
21364       enddo
21365       do k=1,3
21366       gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
21367            +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
21368            + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21369       gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
21370            +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21371            + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21372       gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21373       gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21374       enddo
21375 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
21376        IF ( j.gt.i+1 .and.&
21377         num_conti.le.maxcont) THEN
21378 !C
21379 !C Calculate the contact function. The ith column of the array JCONT will
21380 !C contain the numbers of atoms that make contacts with the atom I (of numbers
21381 !C greater than I). The arrays FACONT and GACONT will contain the values of
21382 !C the contact function and its derivative.
21383       r0ij=2.20D0*sigma_nucl(itypi,itypj)
21384 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
21385       call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
21386 !c        write (2,*) "fcont",fcont
21387       if (fcont.gt.0.0D0) then
21388         num_conti=num_conti+1
21389         num_conti2=num_conti2+1
21390
21391         if (num_conti.gt.maxconts) then
21392           write (iout,*) 'WARNING - max. # of contacts exceeded;',&
21393                     ' will skip next contacts for this conf.',maxconts
21394         else
21395           jcont_hb(num_conti,i)=j
21396 !c            write (iout,*) "num_conti",num_conti,
21397 !c     &        " jcont_hb",jcont_hb(num_conti,i)
21398 !C Calculate contact energies
21399           cosa4=4.0D0*cosa
21400           wij=cosa-3.0D0*cosb*cosg
21401           cosbg1=cosb+cosg
21402           cosbg2=cosb-cosg
21403           fac3=dsqrt(-ael6i)*r3ij
21404 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
21405           ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
21406           if (ees0tmp.gt.0) then
21407             ees0pij=dsqrt(ees0tmp)
21408           else
21409             ees0pij=0
21410           endif
21411           ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
21412           if (ees0tmp.gt.0) then
21413             ees0mij=dsqrt(ees0tmp)
21414           else
21415             ees0mij=0
21416           endif
21417           ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
21418           ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
21419 !c            write (iout,*) "i",i," j",j,
21420 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
21421           ees0pij1=fac3/ees0pij
21422           ees0mij1=fac3/ees0mij
21423           fac3p=-3.0D0*fac3*rrij
21424           ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
21425           ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
21426           ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
21427           ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
21428           ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
21429           ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
21430           ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
21431           ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
21432           ecosap=ecosa1+ecosa2
21433           ecosbp=ecosb1+ecosb2
21434           ecosgp=ecosg1+ecosg2
21435           ecosam=ecosa1-ecosa2
21436           ecosbm=ecosb1-ecosb2
21437           ecosgm=ecosg1-ecosg2
21438 !C End diagnostics
21439           facont_hb(num_conti,i)=fcont
21440           fprimcont=fprimcont/rij
21441           do k=1,3
21442             gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
21443             gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
21444           enddo
21445           gggp(1)=gggp(1)+ees0pijp*xj
21446           gggp(2)=gggp(2)+ees0pijp*yj
21447           gggp(3)=gggp(3)+ees0pijp*zj
21448           gggm(1)=gggm(1)+ees0mijp*xj
21449           gggm(2)=gggm(2)+ees0mijp*yj
21450           gggm(3)=gggm(3)+ees0mijp*zj
21451 !C Derivatives due to the contact function
21452           gacont_hbr(1,num_conti,i)=fprimcont*xj
21453           gacont_hbr(2,num_conti,i)=fprimcont*yj
21454           gacont_hbr(3,num_conti,i)=fprimcont*zj
21455           do k=1,3
21456 !c
21457 !c Gradient of the correlation terms
21458 !c
21459             gacontp_hb1(k,num_conti,i)= &
21460            (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21461           + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21462             gacontp_hb2(k,num_conti,i)= &
21463            (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
21464           + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21465             gacontp_hb3(k,num_conti,i)=gggp(k)
21466             gacontm_hb1(k,num_conti,i)= &
21467            (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21468           + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21469             gacontm_hb2(k,num_conti,i)= &
21470            (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21471           + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21472             gacontm_hb3(k,num_conti,i)=gggm(k)
21473           enddo
21474         endif
21475       endif
21476       ENDIF
21477       return
21478       end subroutine eelsbij
21479 !------------------------------------------------------------------
21480       subroutine sc_grad_nucl
21481       use comm_locel
21482       use calc_data_nucl
21483       real(kind=8),dimension(3) :: dcosom1,dcosom2
21484       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
21485       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
21486       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
21487       do k=1,3
21488       dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
21489       dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
21490       enddo
21491       do k=1,3
21492       gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
21493       enddo
21494       do k=1,3
21495       gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
21496              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
21497              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
21498       gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
21499              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
21500              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
21501       enddo
21502 !C
21503 !C Calculate the components of the gradient in DC and X
21504 !C
21505       do l=1,3
21506       gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
21507       gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
21508       enddo
21509       return
21510       end subroutine sc_grad_nucl
21511 !-----------------------------------------------------------------------
21512       subroutine esb(esbloc)
21513 !C Calculate the local energy of a side chain and its derivatives in the
21514 !C corresponding virtual-bond valence angles THETA and the spherical angles
21515 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
21516 !C added by Urszula Kozlowska. 07/11/2007
21517 !C
21518       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
21519       real(kind=8),dimension(9):: x
21520      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
21521       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
21522       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
21523       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
21524        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
21525        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
21526        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
21527        integer::it,nlobit,i,j,k
21528 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
21529       delta=0.02d0*pi
21530       esbloc=0.0D0
21531       do i=loc_start_nucl,loc_end_nucl
21532       if (itype(i,2).eq.ntyp1_molec(2)) cycle
21533       costtab(i+1) =dcos(theta(i+1))
21534       sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
21535       cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
21536       sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
21537       cosfac2=0.5d0/(1.0d0+costtab(i+1))
21538       cosfac=dsqrt(cosfac2)
21539       sinfac2=0.5d0/(1.0d0-costtab(i+1))
21540       sinfac=dsqrt(sinfac2)
21541       it=itype(i,2)
21542       if (it.eq.10) goto 1
21543
21544 !c
21545 !C  Compute the axes of tghe local cartesian coordinates system; store in
21546 !c   x_prime, y_prime and z_prime
21547 !c
21548       do j=1,3
21549         x_prime(j) = 0.00
21550         y_prime(j) = 0.00
21551         z_prime(j) = 0.00
21552       enddo
21553 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
21554 !C     &   dc_norm(3,i+nres)
21555       do j = 1,3
21556         x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
21557         y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
21558       enddo
21559       do j = 1,3
21560         z_prime(j) = -uz(j,i-1)
21561 !           z_prime(j)=0.0
21562       enddo
21563
21564       xx=0.0d0
21565       yy=0.0d0
21566       zz=0.0d0
21567       do j = 1,3
21568         xx = xx + x_prime(j)*dc_norm(j,i+nres)
21569         yy = yy + y_prime(j)*dc_norm(j,i+nres)
21570         zz = zz + z_prime(j)*dc_norm(j,i+nres)
21571       enddo
21572
21573       xxtab(i)=xx
21574       yytab(i)=yy
21575       zztab(i)=zz
21576        it=itype(i,2)
21577       do j = 1,9
21578         x(j) = sc_parmin_nucl(j,it)
21579       enddo
21580 #ifdef CHECK_COORD
21581 !Cc diagnostics - remove later
21582       xx1 = dcos(alph(2))
21583       yy1 = dsin(alph(2))*dcos(omeg(2))
21584       zz1 = -dsin(alph(2))*dsin(omeg(2))
21585       write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
21586        alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
21587        xx1,yy1,zz1
21588 !C,"  --- ", xx_w,yy_w,zz_w
21589 !c end diagnostics
21590 #endif
21591       sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21592       esbloc = esbloc + sumene
21593       sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
21594 !        print *,"enecomp",sumene,sumene2
21595 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
21596 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
21597 #ifdef DEBUG
21598       write (2,*) "x",(x(k),k=1,9)
21599 !C
21600 !C This section to check the numerical derivatives of the energy of ith side
21601 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
21602 !C #define DEBUG in the code to turn it on.
21603 !C
21604       write (2,*) "sumene               =",sumene
21605       aincr=1.0d-7
21606       xxsave=xx
21607       xx=xx+aincr
21608       write (2,*) xx,yy,zz
21609       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21610       de_dxx_num=(sumenep-sumene)/aincr
21611       xx=xxsave
21612       write (2,*) "xx+ sumene from enesc=",sumenep,sumene
21613       yysave=yy
21614       yy=yy+aincr
21615       write (2,*) xx,yy,zz
21616       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21617       de_dyy_num=(sumenep-sumene)/aincr
21618       yy=yysave
21619       write (2,*) "yy+ sumene from enesc=",sumenep,sumene
21620       zzsave=zz
21621       zz=zz+aincr
21622       write (2,*) xx,yy,zz
21623       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21624       de_dzz_num=(sumenep-sumene)/aincr
21625       zz=zzsave
21626       write (2,*) "zz+ sumene from enesc=",sumenep,sumene
21627       costsave=cost2tab(i+1)
21628       sintsave=sint2tab(i+1)
21629       cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
21630       sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
21631       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21632       de_dt_num=(sumenep-sumene)/aincr
21633       write (2,*) " t+ sumene from enesc=",sumenep,sumene
21634       cost2tab(i+1)=costsave
21635       sint2tab(i+1)=sintsave
21636 !C End of diagnostics section.
21637 #endif
21638 !C
21639 !C Compute the gradient of esc
21640 !C
21641       de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
21642       de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
21643       de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
21644       de_dtt=0.0d0
21645 #ifdef DEBUG
21646       write (2,*) "x",(x(k),k=1,9)
21647       write (2,*) "xx",xx," yy",yy," zz",zz
21648       write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
21649         " de_zz   ",de_zz," de_tt   ",de_tt
21650       write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
21651         " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
21652 #endif
21653 !C
21654        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
21655        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
21656        cosfac2xx=cosfac2*xx
21657        sinfac2yy=sinfac2*yy
21658        do k = 1,3
21659        dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
21660          vbld_inv(i+1)
21661        dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
21662          vbld_inv(i)
21663        pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
21664        pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
21665 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
21666 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
21667 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
21668 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
21669        dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
21670        dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
21671        dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
21672        dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
21673        dZZ_Ci1(k)=0.0d0
21674        dZZ_Ci(k)=0.0d0
21675        do j=1,3
21676          dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
21677          dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
21678        enddo
21679
21680        dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
21681        dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
21682        dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
21683 !c
21684        dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
21685        dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
21686        enddo
21687
21688        do k=1,3
21689        dXX_Ctab(k,i)=dXX_Ci(k)
21690        dXX_C1tab(k,i)=dXX_Ci1(k)
21691        dYY_Ctab(k,i)=dYY_Ci(k)
21692        dYY_C1tab(k,i)=dYY_Ci1(k)
21693        dZZ_Ctab(k,i)=dZZ_Ci(k)
21694        dZZ_C1tab(k,i)=dZZ_Ci1(k)
21695        dXX_XYZtab(k,i)=dXX_XYZ(k)
21696        dYY_XYZtab(k,i)=dYY_XYZ(k)
21697        dZZ_XYZtab(k,i)=dZZ_XYZ(k)
21698        enddo
21699        do k = 1,3
21700 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
21701 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
21702 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
21703 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
21704 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
21705 !c     &    dt_dci(k)
21706 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
21707 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
21708        gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
21709        +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
21710        gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
21711        +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
21712        gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
21713        +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
21714 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
21715        enddo
21716 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
21717 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
21718
21719 !C to check gradient call subroutine check_grad
21720
21721     1 continue
21722       enddo
21723       return
21724       end subroutine esb
21725 !=-------------------------------------------------------
21726       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
21727 !      implicit none
21728       real(kind=8),dimension(9):: x(9)
21729        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
21730       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
21731       integer i
21732 !c      write (2,*) "enesc"
21733 !c      write (2,*) "x",(x(i),i=1,9)
21734 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
21735       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
21736       + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
21737       + x(9)*yy*zz
21738       enesc_nucl=sumene
21739       return
21740       end function enesc_nucl
21741 !-----------------------------------------------------------------------------
21742       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
21743 #ifdef MPI
21744       include 'mpif.h'
21745       integer,parameter :: max_cont=2000
21746       integer,parameter:: max_dim=2*(8*3+6)
21747       integer, parameter :: msglen1=max_cont*max_dim
21748       integer,parameter :: msglen2=2*msglen1
21749       integer source,CorrelType,CorrelID,Error
21750       real(kind=8) :: buffer(max_cont,max_dim)
21751       integer status(MPI_STATUS_SIZE)
21752       integer :: ierror,nbytes
21753 #endif
21754       real(kind=8),dimension(3):: gx(3),gx1(3)
21755       real(kind=8) :: time00
21756       logical lprn,ldone
21757       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
21758       real(kind=8) ecorr,ecorr3
21759       integer :: n_corr,n_corr1,mm,msglen
21760 !C Set lprn=.true. for debugging
21761       lprn=.false.
21762       n_corr=0
21763       n_corr1=0
21764 #ifdef MPI
21765       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
21766
21767       if (nfgtasks.le.1) goto 30
21768       if (lprn) then
21769       write (iout,'(a)') 'Contact function values:'
21770       do i=nnt,nct-1
21771         write (iout,'(2i3,50(1x,i2,f5.2))')  &
21772        i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21773        j=1,num_cont_hb(i))
21774       enddo
21775       endif
21776 !C Caution! Following code assumes that electrostatic interactions concerning
21777 !C a given atom are split among at most two processors!
21778       CorrelType=477
21779       CorrelID=fg_rank+1
21780       ldone=.false.
21781       do i=1,max_cont
21782       do j=1,max_dim
21783         buffer(i,j)=0.0D0
21784       enddo
21785       enddo
21786       mm=mod(fg_rank,2)
21787 !c      write (*,*) 'MyRank',MyRank,' mm',mm
21788       if (mm) 20,20,10
21789    10 continue
21790 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
21791       if (fg_rank.gt.0) then
21792 !C Send correlation contributions to the preceding processor
21793       msglen=msglen1
21794       nn=num_cont_hb(iatel_s_nucl)
21795       call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
21796 !c        write (*,*) 'The BUFFER array:'
21797 !c        do i=1,nn
21798 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
21799 !c        enddo
21800       if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
21801         msglen=msglen2
21802         call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
21803 !C Clear the contacts of the atom passed to the neighboring processor
21804       nn=num_cont_hb(iatel_s_nucl+1)
21805 !c        do i=1,nn
21806 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
21807 !c        enddo
21808           num_cont_hb(iatel_s_nucl)=0
21809       endif
21810 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
21811 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
21812 !cd   & ' msglen=',msglen
21813 !c        write (*,*) 'Processor ',fg_rank,MyRank,
21814 !c     & ' is sending correlation contribution to processor',fg_rank-1,
21815 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21816       time00=MPI_Wtime()
21817       call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
21818        CorrelType,FG_COMM,IERROR)
21819       time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21820 !cd      write (iout,*) 'Processor ',fg_rank,
21821 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
21822 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
21823 !c        write (*,*) 'Processor ',fg_rank,
21824 !c     & ' has sent correlation contribution to processor',fg_rank-1,
21825 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
21826 !c        msglen=msglen1
21827       endif ! (fg_rank.gt.0)
21828       if (ldone) goto 30
21829       ldone=.true.
21830    20 continue
21831 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
21832       if (fg_rank.lt.nfgtasks-1) then
21833 !C Receive correlation contributions from the next processor
21834       msglen=msglen1
21835       if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
21836 !cd      write (iout,*) 'Processor',fg_rank,
21837 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
21838 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
21839 !c        write (*,*) 'Processor',fg_rank,
21840 !c     &' is receiving correlation contribution from processor',fg_rank+1,
21841 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21842       time00=MPI_Wtime()
21843       nbytes=-1
21844       do while (nbytes.le.0)
21845         call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21846         call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
21847       enddo
21848 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
21849       call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
21850        fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21851       time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21852 !c        write (*,*) 'Processor',fg_rank,
21853 !c     &' has received correlation contribution from processor',fg_rank+1,
21854 !c     & ' msglen=',msglen,' nbytes=',nbytes
21855 !c        write (*,*) 'The received BUFFER array:'
21856 !c        do i=1,max_cont
21857 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
21858 !c        enddo
21859       if (msglen.eq.msglen1) then
21860         call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
21861       else if (msglen.eq.msglen2)  then
21862         call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
21863         call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
21864       else
21865         write (iout,*) &
21866       'ERROR!!!! message length changed while processing correlations.'
21867         write (*,*) &
21868       'ERROR!!!! message length changed while processing correlations.'
21869         call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
21870       endif ! msglen.eq.msglen1
21871       endif ! fg_rank.lt.nfgtasks-1
21872       if (ldone) goto 30
21873       ldone=.true.
21874       goto 10
21875    30 continue
21876 #endif
21877       if (lprn) then
21878       write (iout,'(a)') 'Contact function values:'
21879       do i=nnt_molec(2),nct_molec(2)-1
21880         write (iout,'(2i3,50(1x,i2,f5.2))') &
21881        i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21882        j=1,num_cont_hb(i))
21883       enddo
21884       endif
21885       ecorr=0.0D0
21886       ecorr3=0.0d0
21887 !C Remove the loop below after debugging !!!
21888 !      do i=nnt_molec(2),nct_molec(2)
21889 !        do j=1,3
21890 !          gradcorr_nucl(j,i)=0.0D0
21891 !          gradxorr_nucl(j,i)=0.0D0
21892 !          gradcorr3_nucl(j,i)=0.0D0
21893 !          gradxorr3_nucl(j,i)=0.0D0
21894 !        enddo
21895 !      enddo
21896 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
21897 !C Calculate the local-electrostatic correlation terms
21898       do i=iatsc_s_nucl,iatsc_e_nucl
21899       i1=i+1
21900       num_conti=num_cont_hb(i)
21901       num_conti1=num_cont_hb(i+1)
21902 !        print *,i,num_conti,num_conti1
21903       do jj=1,num_conti
21904         j=jcont_hb(jj,i)
21905         do kk=1,num_conti1
21906           j1=jcont_hb(kk,i1)
21907 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
21908 !c     &         ' jj=',jj,' kk=',kk
21909           if (j1.eq.j+1 .or. j1.eq.j-1) then
21910 !C
21911 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
21912 !C The system gains extra energy.
21913 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
21914 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21915 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
21916 !C
21917             ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21918             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
21919              'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21920             n_corr=n_corr+1
21921           else if (j1.eq.j) then
21922 !C
21923 !C Contacts I-J and I-(J+1) occur simultaneously.
21924 !C The system loses extra energy.
21925 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
21926 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21927 !C Need to implement full formulas 32 from Liwo et al., 1998.
21928 !C
21929 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21930 !c     &         ' jj=',jj,' kk=',kk
21931             ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
21932           endif
21933         enddo ! kk
21934         do kk=1,num_conti
21935           j1=jcont_hb(kk,i)
21936 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21937 !c     &         ' jj=',jj,' kk=',kk
21938           if (j1.eq.j+1) then
21939 !C Contacts I-J and (I+1)-J occur simultaneously.
21940 !C The system loses extra energy.
21941             ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
21942           endif ! j1==j+1
21943         enddo ! kk
21944       enddo ! jj
21945       enddo ! i
21946       return
21947       end subroutine multibody_hb_nucl
21948 !-----------------------------------------------------------
21949       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21950 !      implicit real*8 (a-h,o-z)
21951 !      include 'DIMENSIONS'
21952 !      include 'COMMON.IOUNITS'
21953 !      include 'COMMON.DERIV'
21954 !      include 'COMMON.INTERACT'
21955 !      include 'COMMON.CONTACTS'
21956       real(kind=8),dimension(3) :: gx,gx1
21957       logical :: lprn
21958 !el local variables
21959       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21960       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21961                ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21962                coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21963                rlocshield
21964
21965       lprn=.false.
21966       eij=facont_hb(jj,i)
21967       ekl=facont_hb(kk,k)
21968       ees0pij=ees0p(jj,i)
21969       ees0pkl=ees0p(kk,k)
21970       ees0mij=ees0m(jj,i)
21971       ees0mkl=ees0m(kk,k)
21972       ekont=eij*ekl
21973       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21974 !      print *,"ehbcorr_nucl",ekont,ees
21975 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21976 !C Following 4 lines for diagnostics.
21977 !cd    ees0pkl=0.0D0
21978 !cd    ees0pij=1.0D0
21979 !cd    ees0mkl=0.0D0
21980 !cd    ees0mij=1.0D0
21981 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21982 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21983 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21984 !C Calculate the multi-body contribution to energy.
21985 !      ecorr_nucl=ecorr_nucl+ekont*ees
21986 !C Calculate multi-body contributions to the gradient.
21987       coeffpees0pij=coeffp*ees0pij
21988       coeffmees0mij=coeffm*ees0mij
21989       coeffpees0pkl=coeffp*ees0pkl
21990       coeffmees0mkl=coeffm*ees0mkl
21991       do ll=1,3
21992       gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
21993        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21994        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21995       gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
21996       -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
21997       coeffmees0mkl*gacontm_hb2(ll,jj,i))
21998       gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
21999       -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
22000       coeffmees0mij*gacontm_hb1(ll,kk,k))
22001       gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
22002       -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22003       coeffmees0mij*gacontm_hb2(ll,kk,k))
22004       gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22005         ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22006         coeffmees0mkl*gacontm_hb3(ll,jj,i))
22007       gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
22008       gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
22009       gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22010         ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22011         coeffmees0mij*gacontm_hb3(ll,kk,k))
22012       gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
22013       gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
22014       gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
22015       gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
22016       gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
22017       gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
22018       enddo
22019       ehbcorr_nucl=ekont*ees
22020       return
22021       end function ehbcorr_nucl
22022 !-------------------------------------------------------------------------
22023
22024      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22025 !      implicit real*8 (a-h,o-z)
22026 !      include 'DIMENSIONS'
22027 !      include 'COMMON.IOUNITS'
22028 !      include 'COMMON.DERIV'
22029 !      include 'COMMON.INTERACT'
22030 !      include 'COMMON.CONTACTS'
22031       real(kind=8),dimension(3) :: gx,gx1
22032       logical :: lprn
22033 !el local variables
22034       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22035       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22036                ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22037                coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22038                rlocshield
22039
22040       lprn=.false.
22041       eij=facont_hb(jj,i)
22042       ekl=facont_hb(kk,k)
22043       ees0pij=ees0p(jj,i)
22044       ees0pkl=ees0p(kk,k)
22045       ees0mij=ees0m(jj,i)
22046       ees0mkl=ees0m(kk,k)
22047       ekont=eij*ekl
22048       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22049 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22050 !C Following 4 lines for diagnostics.
22051 !cd    ees0pkl=0.0D0
22052 !cd    ees0pij=1.0D0
22053 !cd    ees0mkl=0.0D0
22054 !cd    ees0mij=1.0D0
22055 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22056 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22057 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22058 !C Calculate the multi-body contribution to energy.
22059 !      ecorr=ecorr+ekont*ees
22060 !C Calculate multi-body contributions to the gradient.
22061       coeffpees0pij=coeffp*ees0pij
22062       coeffmees0mij=coeffm*ees0mij
22063       coeffpees0pkl=coeffp*ees0pkl
22064       coeffmees0mkl=coeffm*ees0mkl
22065       do ll=1,3
22066       gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
22067        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22068        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22069       gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
22070       -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
22071       coeffmees0mkl*gacontm_hb2(ll,jj,i))
22072       gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
22073       -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
22074       coeffmees0mij*gacontm_hb1(ll,kk,k))
22075       gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
22076       -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22077       coeffmees0mij*gacontm_hb2(ll,kk,k))
22078       gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22079         ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22080         coeffmees0mkl*gacontm_hb3(ll,jj,i))
22081       gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
22082       gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
22083       gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22084         ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22085         coeffmees0mij*gacontm_hb3(ll,kk,k))
22086       gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
22087       gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
22088       gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
22089       gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
22090       gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
22091       gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
22092       enddo
22093       ehbcorr3_nucl=ekont*ees
22094       return
22095       end function ehbcorr3_nucl
22096 #ifdef MPI
22097       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
22098       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22099       real(kind=8):: buffer(dimen1,dimen2)
22100       num_kont=num_cont_hb(atom)
22101       do i=1,num_kont
22102       do k=1,8
22103         do j=1,3
22104           buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
22105         enddo ! j
22106       enddo ! k
22107       buffer(i,indx+25)=facont_hb(i,atom)
22108       buffer(i,indx+26)=ees0p(i,atom)
22109       buffer(i,indx+27)=ees0m(i,atom)
22110       buffer(i,indx+28)=d_cont(i,atom)
22111       buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
22112       enddo ! i
22113       buffer(1,indx+30)=dfloat(num_kont)
22114       return
22115       end subroutine pack_buffer
22116 !c------------------------------------------------------------------------------
22117       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
22118       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22119       real(kind=8):: buffer(dimen1,dimen2)
22120 !      double precision zapas
22121 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
22122 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
22123 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
22124 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
22125       num_kont=buffer(1,indx+30)
22126       num_kont_old=num_cont_hb(atom)
22127       num_cont_hb(atom)=num_kont+num_kont_old
22128       do i=1,num_kont
22129       ii=i+num_kont_old
22130       do k=1,8
22131         do j=1,3
22132           zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
22133         enddo ! j
22134       enddo ! k
22135       facont_hb(ii,atom)=buffer(i,indx+25)
22136       ees0p(ii,atom)=buffer(i,indx+26)
22137       ees0m(ii,atom)=buffer(i,indx+27)
22138       d_cont(i,atom)=buffer(i,indx+28)
22139       jcont_hb(ii,atom)=buffer(i,indx+29)
22140       enddo ! i
22141       return
22142       end subroutine unpack_buffer
22143 !c------------------------------------------------------------------------------
22144 #endif
22145       subroutine ecatcat(ecationcation)
22146       integer :: i,j,itmp,xshift,yshift,zshift,subchap,k,itypi,itypj
22147       real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22148       r7,r4,ecationcation,k0,rcal,aa,bb,sslipi,ssgradlipi,sslipj,ssgradlipj
22149       real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22150       dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
22151       real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22152       gg,r
22153
22154       ecationcation=0.0d0
22155       if (nres_molec(5).eq.0) return
22156       rcat0=3.472
22157       epscalc=0.05
22158       r06 = rcat0**6
22159       r012 = r06**2
22160 !        k0 = 332.0*(2.0*2.0)/80.0
22161       itmp=0
22162
22163       do i=1,4
22164       itmp=itmp+nres_molec(i)
22165       enddo
22166 !        write(iout,*) "itmp",itmp
22167       do i=itmp+1,itmp+nres_molec(5)-1
22168
22169       xi=c(1,i)
22170       yi=c(2,i)
22171       zi=c(3,i)
22172 !        write (iout,*) i,"TUTUT",c(1,i)
22173         itypi=itype(i,5)
22174       call to_box(xi,yi,zi)
22175       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
22176         do j=i+1,itmp+nres_molec(5)
22177         itypj=itype(j,5)
22178 !          print *,i,j,itypi,itypj
22179         k0 = 332.0*(ichargecat(itypi)*ichargecat(itypj))/80.0
22180 !           print *,i,j,'catcat'
22181          xj=c(1,j)
22182          yj=c(2,j)
22183          zj=c(3,j)
22184       call to_box(xj,yj,zj)
22185       call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
22186       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22187        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22188       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22189        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22190       xj=boxshift(xj-xi,boxxsize)
22191       yj=boxshift(yj-yi,boxysize)
22192       zj=boxshift(zj-zi,boxzsize)
22193        rcal =xj**2+yj**2+zj**2
22194       ract=sqrt(rcal)
22195 !        rcat0=3.472
22196 !        epscalc=0.05
22197 !        r06 = rcat0**6
22198 !        r012 = r06**2
22199 !        k0 = 332*(2*2)/80
22200       Evan1cat=epscalc*(r012/(rcal**6))
22201       Evan2cat=epscalc*2*(r06/(rcal**3))
22202       Eeleccat=k0/ract
22203       r7 = rcal**7
22204       r4 = rcal**4
22205       r(1)=xj
22206       r(2)=yj
22207       r(3)=zj
22208       do k=1,3
22209         dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
22210         dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
22211         dEeleccat(k)=-k0*r(k)/ract**3
22212       enddo
22213       do k=1,3
22214         gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
22215         gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
22216         gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
22217       enddo
22218       if (energy_dec) write (iout,*) i,j,Evan1cat,Evan2cat,Eeleccat,&
22219        r012,rcal**6,ichargecat(itypi)*ichargecat(itypj)
22220 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
22221       ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
22222        enddo
22223        enddo
22224        return
22225        end subroutine ecatcat
22226 !---------------------------------------------------------------------------
22227 ! new for K+
22228       subroutine ecats_prot_amber(evdw)
22229 !      subroutine ecat_prot2(ecation_prot)
22230       use calc_data
22231       use comm_momo
22232
22233       logical :: lprn
22234 !el local variables
22235       integer :: iint,itypi1,subchap,isel,itmp
22236       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
22237       real(kind=8) :: evdw,aa,bb
22238       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22239                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
22240                 sslipi,sslipj,faclip,alpha_sco
22241       integer :: ii
22242       real(kind=8) :: fracinbuf
22243       real (kind=8) :: escpho
22244       real (kind=8),dimension(4):: ener
22245       real(kind=8) :: b1,b2,egb
22246       real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
22247        Lambf,&
22248        Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
22249        ecations_prot_amber,dFdOM2,dFdL,dFdOM12,&
22250        federmaus,&
22251        d1i,d1j
22252 !       real(kind=8),dimension(3,2)::erhead_tail
22253 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
22254       real(kind=8) ::  facd4, adler, Fgb, facd3
22255       integer troll,jj,istate
22256       real (kind=8) :: dcosom1(3),dcosom2(3)
22257
22258       evdw=0.0D0
22259       if (nres_molec(5).eq.0) return
22260       eps_out=80.0d0
22261 !      sss_ele_cut=1.0d0
22262
22263       itmp=0
22264       do i=1,4
22265       itmp=itmp+nres_molec(i)
22266       enddo
22267 !        go to 17
22268 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
22269       do i=ibond_start,ibond_end
22270
22271 !        print *,"I am in EVDW",i
22272       itypi=iabs(itype(i,1))
22273
22274 !        if (i.ne.47) cycle
22275       if ((itypi.eq.ntyp1).or.(itypi.eq.10)) cycle
22276       itypi1=iabs(itype(i+1,1))
22277       xi=c(1,nres+i)
22278       yi=c(2,nres+i)
22279       zi=c(3,nres+i)
22280       call to_box(xi,yi,zi)
22281       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
22282       dxi=dc_norm(1,nres+i)
22283       dyi=dc_norm(2,nres+i)
22284       dzi=dc_norm(3,nres+i)
22285       dsci_inv=vbld_inv(i+nres)
22286        do j=itmp+1,itmp+nres_molec(5)
22287
22288 ! Calculate SC interaction energy.
22289           itypj=iabs(itype(j,5))
22290           if ((itypj.eq.ntyp1)) cycle
22291            CALL elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
22292
22293           dscj_inv=0.0
22294          xj=c(1,j)
22295          yj=c(2,j)
22296          zj=c(3,j)
22297
22298       call to_box(xj,yj,zj)
22299       call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
22300       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22301        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22302       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22303        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22304       xj=boxshift(xj-xi,boxxsize)
22305       yj=boxshift(yj-yi,boxysize)
22306       zj=boxshift(zj-zi,boxzsize)
22307
22308 !          dxj = dc_norm( 1, nres+j )
22309 !          dyj = dc_norm( 2, nres+j )
22310 !          dzj = dc_norm( 3, nres+j )
22311
22312         itypi = itype(i,1)
22313         itypj = itype(j,5)
22314 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
22315 ! sampling performed with amber package
22316 !          alf1   = 0.0d0
22317 !          alf2   = 0.0d0
22318 !          alf12  = 0.0d0
22319 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
22320         chi1 = chi1cat(itypi,itypj)
22321         chis1 = chis1cat(itypi,itypj)
22322         chip1 = chipp1cat(itypi,itypj)
22323 !          chi1=0.0d0
22324 !          chis1=0.0d0
22325 !          chip1=0.0d0
22326         chi2=0.0
22327         chip2=0.0
22328         chis2=0.0
22329 !          chis2 = chis(itypj,itypi)
22330         chis12 = chis1 * chis2
22331         sig1 = sigmap1cat(itypi,itypj)
22332 !          sig2 = sigmap2(itypi,itypj)
22333 ! alpha factors from Fcav/Gcav
22334         b1cav = alphasurcat(1,itypi,itypj)
22335         b2cav = alphasurcat(2,itypi,itypj)
22336         b3cav = alphasurcat(3,itypi,itypj)
22337         b4cav = alphasurcat(4,itypi,itypj)
22338
22339 ! used to determine whether we want to do quadrupole calculations
22340        eps_in = epsintabcat(itypi,itypj)
22341        if (eps_in.eq.0.0) eps_in=1.0
22342
22343        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
22344 !       Rtail = 0.0d0
22345
22346        DO k = 1, 3
22347       ctail(k,1)=c(k,i+nres)
22348       ctail(k,2)=c(k,j)
22349        END DO
22350 !c! tail distances will be themselves usefull elswhere
22351 !c1 (in Gcav, for example)
22352        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
22353        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
22354        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
22355        Rtail = dsqrt( &
22356         (Rtail_distance(1)*Rtail_distance(1)) &
22357       + (Rtail_distance(2)*Rtail_distance(2)) &
22358       + (Rtail_distance(3)*Rtail_distance(3)))
22359 ! tail location and distance calculations
22360 ! dhead1
22361        d1 = dheadcat(1, 1, itypi, itypj)
22362 !       d2 = dhead(2, 1, itypi, itypj)
22363        DO k = 1,3
22364 ! location of polar head is computed by taking hydrophobic centre
22365 ! and moving by a d1 * dc_norm vector
22366 ! see unres publications for very informative images
22367       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
22368       chead(k,2) = c(k, j)
22369 ! distance
22370 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22371 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22372       Rhead_distance(k) = chead(k,2) - chead(k,1)
22373        END DO
22374 ! pitagoras (root of sum of squares)
22375        Rhead = dsqrt( &
22376         (Rhead_distance(1)*Rhead_distance(1)) &
22377       + (Rhead_distance(2)*Rhead_distance(2)) &
22378       + (Rhead_distance(3)*Rhead_distance(3)))
22379 !-------------------------------------------------------------------
22380 ! zero everything that should be zero'ed
22381        evdwij = 0.0d0
22382        ECL = 0.0d0
22383        Elj = 0.0d0
22384        Equad = 0.0d0
22385        Epol = 0.0d0
22386        Fcav=0.0d0
22387        eheadtail = 0.0d0
22388        dGCLdOM1 = 0.0d0
22389        dGCLdOM2 = 0.0d0
22390        dGCLdOM12 = 0.0d0
22391        dPOLdOM1 = 0.0d0
22392        dPOLdOM2 = 0.0d0
22393         Fcav = 0.0d0
22394         dFdR = 0.0d0
22395         dCAVdOM1  = 0.0d0
22396         dCAVdOM2  = 0.0d0
22397         dCAVdOM12 = 0.0d0
22398         dscj_inv = vbld_inv(j+nres)
22399 !          print *,i,j,dscj_inv,dsci_inv
22400 ! rij holds 1/(distance of Calpha atoms)
22401         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
22402         rij  = dsqrt(rrij)
22403         CALL sc_angular
22404 ! this should be in elgrad_init but om's are calculated by sc_angular
22405 ! which in turn is used by older potentials
22406 ! om = omega, sqom = om^2
22407         sqom1  = om1 * om1
22408         sqom2  = om2 * om2
22409         sqom12 = om12 * om12
22410
22411 ! now we calculate EGB - Gey-Berne
22412 ! It will be summed up in evdwij and saved in evdw
22413         sigsq     = 1.0D0  / sigsq
22414         sig       = sig0ij * dsqrt(sigsq)
22415 !          rij_shift = 1.0D0  / rij - sig + sig0ij
22416         rij_shift = Rtail - sig + sig0ij
22417         IF (rij_shift.le.0.0D0) THEN
22418          evdw = 1.0D20
22419          RETURN
22420         END IF
22421         sigder = -sig * sigsq
22422         rij_shift = 1.0D0 / rij_shift
22423         fac       = rij_shift**expon
22424         c1        = fac  * fac * aa_aq_cat(itypi,itypj)
22425 !          print *,"ADAM",aa_aq(itypi,itypj)
22426
22427 !          c1        = 0.0d0
22428         c2        = fac  * bb_aq_cat(itypi,itypj)
22429 !          c2        = 0.0d0
22430         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
22431         eps2der   = eps3rt * evdwij
22432         eps3der   = eps2rt * evdwij
22433 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
22434         evdwij    = eps2rt * eps3rt * evdwij
22435 !#ifdef TSCSC
22436 !          IF (bb_aq(itypi,itypj).gt.0) THEN
22437 !           evdw_p = evdw_p + evdwij
22438 !          ELSE
22439 !           evdw_m = evdw_m + evdwij
22440 !          END IF
22441 !#else
22442         evdw = evdw  &
22443             + evdwij
22444 !#endif
22445         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
22446         fac    = -expon * (c1 + evdwij) * rij_shift
22447         sigder = fac * sigder
22448 ! Calculate distance derivative
22449         gg(1) =  fac
22450         gg(2) =  fac
22451         gg(3) =  fac
22452
22453         fac = chis1 * sqom1 + chis2 * sqom2 &
22454         - 2.0d0 * chis12 * om1 * om2 * om12
22455         pom = 1.0d0 - chis1 * chis2 * sqom12
22456         Lambf = (1.0d0 - (fac / pom))
22457         Lambf = dsqrt(Lambf)
22458         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
22459         Chif = Rtail * sparrow
22460         ChiLambf = Chif * Lambf
22461         eagle = dsqrt(ChiLambf)
22462         bat = ChiLambf ** 11.0d0
22463         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
22464         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
22465         botsq = bot * bot
22466         Fcav = top / bot
22467
22468        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
22469        dbot = 12.0d0 * b4cav * bat * Lambf
22470        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
22471
22472         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
22473         dbot = 12.0d0 * b4cav * bat * Chif
22474         eagle = Lambf * pom
22475         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
22476         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
22477         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
22478             * (chis2 * om2 * om12 - om1) / (eagle * pom)
22479
22480         dFdL = ((dtop * bot - top * dbot) / botsq)
22481         dCAVdOM1  = dFdL * ( dFdOM1 )
22482         dCAVdOM2  = dFdL * ( dFdOM2 )
22483         dCAVdOM12 = dFdL * ( dFdOM12 )
22484
22485        DO k= 1, 3
22486       ertail(k) = Rtail_distance(k)/Rtail
22487        END DO
22488        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
22489        erdxj = scalar( ertail(1), dC_norm(1,j) )
22490        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
22491        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j+nres)
22492        DO k = 1, 3
22493       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
22494       gradpepcatx(k,i) = gradpepcatx(k,i) &
22495               - (( dFdR + gg(k) ) * pom)
22496       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
22497 !        gvdwx(k,j) = gvdwx(k,j)   &
22498 !                  + (( dFdR + gg(k) ) * pom)
22499       gradpepcat(k,i) = gradpepcat(k,i)  &
22500               - (( dFdR + gg(k) ) * ertail(k))
22501       gradpepcat(k,j) = gradpepcat(k,j) &
22502               + (( dFdR + gg(k) ) * ertail(k))
22503       gg(k) = 0.0d0
22504        ENDDO
22505 !c! Compute head-head and head-tail energies for each state
22506         isel = iabs(Qi) + 1 ! ion is always charged so  iabs(Qj)
22507         IF (isel.eq.0) THEN
22508 !c! No charges - do nothing
22509          eheadtail = 0.0d0
22510
22511         ELSE IF (isel.eq.1) THEN
22512 !c! Nonpolar-charge interactions
22513         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22514           Qi=Qi*2
22515           Qij=Qij*2
22516          endif
22517         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
22518           Qj=Qj*2
22519           Qij=Qij*2
22520          endif
22521
22522          CALL enq_cat(epol)
22523          eheadtail = epol
22524 !           eheadtail = 0.0d0
22525
22526         ELSE IF (isel.eq.3) THEN
22527 !c! Dipole-charge interactions
22528         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22529           Qi=Qi*2
22530           Qij=Qij*2
22531          endif
22532         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
22533           Qj=Qj*2
22534           Qij=Qij*2
22535          endif
22536          write(iout,*) "KURWA0",d1
22537
22538          CALL edq_cat(ecl, elj, epol)
22539         eheadtail = ECL + elj + epol
22540 !           eheadtail = 0.0d0
22541
22542         ELSE IF ((isel.eq.2)) THEN
22543
22544 !c! Same charge-charge interaction ( +/+ or -/- )
22545         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22546           Qi=Qi*2
22547           Qij=Qij*2
22548          endif
22549         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
22550           Qj=Qj*2
22551           Qij=Qij*2
22552          endif
22553
22554          CALL eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
22555          eheadtail = ECL + Egb + Epol + Fisocav + Elj
22556 !           eheadtail = 0.0d0
22557
22558 !          ELSE IF ((isel.eq.2.and.  &
22559 !               iabs(Qi).eq.1).and. &
22560 !               nstate(itypi,itypj).ne.1) THEN
22561 !c! Different charge-charge interaction ( +/- or -/+ )
22562 !          if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22563 !            Qi=Qi*2
22564 !            Qij=Qij*2
22565 !           endif
22566 !          if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
22567 !            Qj=Qj*2
22568 !            Qij=Qij*2
22569 !           endif
22570 !
22571 !           CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
22572        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
22573       evdw = evdw  + Fcav + eheadtail
22574
22575        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
22576       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
22577       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
22578       Equad,evdwij+Fcav+eheadtail,evdw
22579 !       evdw = evdw  + Fcav  + eheadtail
22580
22581 !        iF (nstate(itypi,itypj).eq.1) THEN
22582       CALL sc_grad_cat
22583 !       END IF
22584 !c!-------------------------------------------------------------------
22585 !c! NAPISY KONCOWE
22586        END DO   ! j
22587        END DO     ! i
22588 !c      write (iout,*) "Number of loop steps in EGB:",ind
22589 !c      energy_dec=.false.
22590 !              print *,"EVDW KURW",evdw,nres
22591 !!!        return
22592    17   continue
22593       do i=ibond_start,ibond_end
22594
22595 !        print *,"I am in EVDW",i
22596       itypi=10 ! the peptide group parameters are for glicine
22597
22598 !        if (i.ne.47) cycle
22599       if ((itype(i,1).eq.ntyp1).or.itype(i+1,1).eq.ntyp1) cycle
22600       itypi1=iabs(itype(i+1,1))
22601       xi=(c(1,i)+c(1,i+1))/2.0
22602       yi=(c(2,i)+c(2,i+1))/2.0
22603       zi=(c(3,i)+c(3,i+1))/2.0
22604         call to_box(xi,yi,zi)
22605       dxi=dc_norm(1,i)
22606       dyi=dc_norm(2,i)
22607       dzi=dc_norm(3,i)
22608       dsci_inv=vbld_inv(i+1)/2.0
22609        do j=itmp+1,itmp+nres_molec(5)
22610
22611 ! Calculate SC interaction energy.
22612           itypj=iabs(itype(j,5))
22613           if ((itypj.eq.ntyp1)) cycle
22614            CALL elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
22615
22616           dscj_inv=0.0
22617          xj=c(1,j)
22618          yj=c(2,j)
22619          zj=c(3,j)
22620         call to_box(xj,yj,zj)
22621         dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22622
22623         dxj = 0.0d0! dc_norm( 1, nres+j )
22624         dyj = 0.0d0!dc_norm( 2, nres+j )
22625         dzj = 0.0d0! dc_norm( 3, nres+j )
22626
22627         itypi = 10
22628         itypj = itype(j,5)
22629 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
22630 ! sampling performed with amber package
22631 !          alf1   = 0.0d0
22632 !          alf2   = 0.0d0
22633 !          alf12  = 0.0d0
22634 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
22635         chi1 = chi1cat(itypi,itypj)
22636         chis1 = chis1cat(itypi,itypj)
22637         chip1 = chipp1cat(itypi,itypj)
22638 !          chi1=0.0d0
22639 !          chis1=0.0d0
22640 !          chip1=0.0d0
22641         chi2=0.0
22642         chip2=0.0
22643         chis2=0.0
22644 !          chis2 = chis(itypj,itypi)
22645         chis12 = chis1 * chis2
22646         sig1 = sigmap1cat(itypi,itypj)
22647 !          sig2 = sigmap2(itypi,itypj)
22648 ! alpha factors from Fcav/Gcav
22649         b1cav = alphasurcat(1,itypi,itypj)
22650         b2cav = alphasurcat(2,itypi,itypj)
22651         b3cav = alphasurcat(3,itypi,itypj)
22652         b4cav = alphasurcat(4,itypi,itypj)
22653
22654 ! used to determine whether we want to do quadrupole calculations
22655        eps_in = epsintabcat(itypi,itypj)
22656        if (eps_in.eq.0.0) eps_in=1.0
22657
22658        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
22659 !       Rtail = 0.0d0
22660
22661        DO k = 1, 3
22662       ctail(k,1)=(c(k,i)+c(k,i+1))/2.0
22663       ctail(k,2)=c(k,j)
22664        END DO
22665 !c! tail distances will be themselves usefull elswhere
22666 !c1 (in Gcav, for example)
22667        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
22668        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
22669        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
22670        Rtail = dsqrt( &
22671         (Rtail_distance(1)*Rtail_distance(1)) &
22672       + (Rtail_distance(2)*Rtail_distance(2)) &
22673       + (Rtail_distance(3)*Rtail_distance(3)))
22674 ! tail location and distance calculations
22675 ! dhead1
22676        d1 = dheadcat(1, 1, itypi, itypj)
22677 !       print *,"d1",d1
22678 !       d1=0.0d0
22679 !       d2 = dhead(2, 1, itypi, itypj)
22680        DO k = 1,3
22681 ! location of polar head is computed by taking hydrophobic centre
22682 ! and moving by a d1 * dc_norm vector
22683 ! see unres publications for very informative images
22684       chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
22685       chead(k,2) = c(k, j)
22686 ! distance
22687 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22688 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22689       Rhead_distance(k) = chead(k,2) - chead(k,1)
22690        END DO
22691 ! pitagoras (root of sum of squares)
22692        Rhead = dsqrt( &
22693         (Rhead_distance(1)*Rhead_distance(1)) &
22694       + (Rhead_distance(2)*Rhead_distance(2)) &
22695       + (Rhead_distance(3)*Rhead_distance(3)))
22696 !-------------------------------------------------------------------
22697 ! zero everything that should be zero'ed
22698        evdwij = 0.0d0
22699        ECL = 0.0d0
22700        Elj = 0.0d0
22701        Equad = 0.0d0
22702        Epol = 0.0d0
22703        Fcav=0.0d0
22704        eheadtail = 0.0d0
22705        dGCLdOM1 = 0.0d0
22706        dGCLdOM2 = 0.0d0
22707        dGCLdOM12 = 0.0d0
22708        dPOLdOM1 = 0.0d0
22709        dPOLdOM2 = 0.0d0
22710         Fcav = 0.0d0
22711         dFdR = 0.0d0
22712         dCAVdOM1  = 0.0d0
22713         dCAVdOM2  = 0.0d0
22714         dCAVdOM12 = 0.0d0
22715         dscj_inv = vbld_inv(j+nres)
22716 !          print *,i,j,dscj_inv,dsci_inv
22717 ! rij holds 1/(distance of Calpha atoms)
22718         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
22719         rij  = dsqrt(rrij)
22720         CALL sc_angular
22721 ! this should be in elgrad_init but om's are calculated by sc_angular
22722 ! which in turn is used by older potentials
22723 ! om = omega, sqom = om^2
22724         sqom1  = om1 * om1
22725         sqom2  = om2 * om2
22726         sqom12 = om12 * om12
22727
22728 ! now we calculate EGB - Gey-Berne
22729 ! It will be summed up in evdwij and saved in evdw
22730         sigsq     = 1.0D0  / sigsq
22731         sig       = sig0ij * dsqrt(sigsq)
22732 !          rij_shift = 1.0D0  / rij - sig + sig0ij
22733         rij_shift = Rtail - sig + sig0ij
22734         IF (rij_shift.le.0.0D0) THEN
22735          evdw = 1.0D20
22736          RETURN
22737         END IF
22738         sigder = -sig * sigsq
22739         rij_shift = 1.0D0 / rij_shift
22740         fac       = rij_shift**expon
22741         c1        = fac  * fac * aa_aq_cat(itypi,itypj)
22742 !          print *,"ADAM",aa_aq(itypi,itypj)
22743
22744 !          c1        = 0.0d0
22745         c2        = fac  * bb_aq_cat(itypi,itypj)
22746 !          c2        = 0.0d0
22747         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
22748         eps2der   = eps3rt * evdwij
22749         eps3der   = eps2rt * evdwij
22750 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
22751         evdwij    = eps2rt * eps3rt * evdwij
22752 !#ifdef TSCSC
22753 !          IF (bb_aq(itypi,itypj).gt.0) THEN
22754 !           evdw_p = evdw_p + evdwij
22755 !          ELSE
22756 !           evdw_m = evdw_m + evdwij
22757 !          END IF
22758 !#else
22759         evdw = evdw  &
22760             + evdwij
22761 !#endif
22762         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
22763         fac    = -expon * (c1 + evdwij) * rij_shift
22764         sigder = fac * sigder
22765 ! Calculate distance derivative
22766         gg(1) =  fac
22767         gg(2) =  fac
22768         gg(3) =  fac
22769
22770         fac = chis1 * sqom1 + chis2 * sqom2 &
22771         - 2.0d0 * chis12 * om1 * om2 * om12
22772
22773         pom = 1.0d0 - chis1 * chis2 * sqom12
22774 !          print *,"TUT2",fac,chis1,sqom1,pom
22775         Lambf = (1.0d0 - (fac / pom))
22776         Lambf = dsqrt(Lambf)
22777         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
22778         Chif = Rtail * sparrow
22779         ChiLambf = Chif * Lambf
22780         eagle = dsqrt(ChiLambf)
22781         bat = ChiLambf ** 11.0d0
22782         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
22783         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
22784         botsq = bot * bot
22785         Fcav = top / bot
22786
22787        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
22788        dbot = 12.0d0 * b4cav * bat * Lambf
22789        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
22790
22791         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
22792         dbot = 12.0d0 * b4cav * bat * Chif
22793         eagle = Lambf * pom
22794         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
22795         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
22796         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
22797             * (chis2 * om2 * om12 - om1) / (eagle * pom)
22798
22799         dFdL = ((dtop * bot - top * dbot) / botsq)
22800         dCAVdOM1  = dFdL * ( dFdOM1 )
22801         dCAVdOM2  = dFdL * ( dFdOM2 )
22802         dCAVdOM12 = dFdL * ( dFdOM12 )
22803
22804        DO k= 1, 3
22805       ertail(k) = Rtail_distance(k)/Rtail
22806        END DO
22807        erdxi = scalar( ertail(1), dC_norm(1,i) )
22808        erdxj = scalar( ertail(1), dC_norm(1,j) )
22809        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i)
22810        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j+nres)
22811        DO k = 1, 3
22812       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i))
22813 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
22814 !                  - (( dFdR + gg(k) ) * pom)
22815       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
22816 !        gvdwx(k,j) = gvdwx(k,j)   &
22817 !                  + (( dFdR + gg(k) ) * pom)
22818       gradpepcat(k,i) = gradpepcat(k,i)  &
22819               - (( dFdR + gg(k) ) * ertail(k))/2.0d0
22820       gradpepcat(k,i+1) = gradpepcat(k,i+1)  &
22821               - (( dFdR + gg(k) ) * ertail(k))/2.0d0
22822
22823       gradpepcat(k,j) = gradpepcat(k,j) &
22824               + (( dFdR + gg(k) ) * ertail(k))
22825       gg(k) = 0.0d0
22826        ENDDO
22827 !c! Compute head-head and head-tail energies for each state
22828         isel = 3
22829 !c! Dipole-charge interactions
22830         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22831           Qi=Qi*2
22832           Qij=Qij*2
22833          endif
22834         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
22835           Qj=Qj*2
22836           Qij=Qij*2
22837          endif
22838          CALL edq_cat_pep(ecl, elj, epol)
22839          eheadtail = ECL + elj + epol
22840 !          print *,"i,",i,eheadtail
22841 !           eheadtail = 0.0d0
22842
22843       evdw = evdw  + Fcav + eheadtail
22844
22845        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
22846       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
22847       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
22848       Equad,evdwij+Fcav+eheadtail,evdw
22849 !       evdw = evdw  + Fcav  + eheadtail
22850
22851 !        iF (nstate(itypi,itypj).eq.1) THEN
22852       CALL sc_grad_cat_pep
22853 !       END IF
22854 !c!-------------------------------------------------------------------
22855 !c! NAPISY KONCOWE
22856        END DO   ! j
22857        END DO     ! i
22858 !c      write (iout,*) "Number of loop steps in EGB:",ind
22859 !c      energy_dec=.false.
22860 !              print *,"EVDW KURW",evdw,nres
22861
22862
22863       return
22864       end subroutine ecats_prot_amber
22865
22866 !---------------------------------------------------------------------------
22867 ! old for Ca2+
22868        subroutine ecat_prot(ecation_prot)
22869 !      use calc_data
22870 !      use comm_momo
22871        integer i,j,k,subchap,itmp,inum
22872       real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22873       r7,r4,ecationcation
22874       real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22875       dist_init,dist_temp,ecation_prot,rcal,rocal,   &
22876       Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
22877       catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
22878       wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
22879       costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
22880       Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
22881       rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
22882       opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
22883       opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
22884       Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip,&
22885       ndiv,ndivi
22886       real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22887       gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
22888       dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
22889       tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
22890       v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
22891       dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
22892       dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
22893       dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
22894       dEvan1Cat
22895       real(kind=8),dimension(6) :: vcatprm
22896       ecation_prot=0.0d0
22897 ! first lets calculate interaction with peptide groups
22898       if (nres_molec(5).eq.0) return
22899       itmp=0
22900       do i=1,4
22901       itmp=itmp+nres_molec(i)
22902       enddo
22903 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
22904       do i=ibond_start,ibond_end
22905 !         cycle
22906        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
22907       xi=0.5d0*(c(1,i)+c(1,i+1))
22908       yi=0.5d0*(c(2,i)+c(2,i+1))
22909       zi=0.5d0*(c(3,i)+c(3,i+1))
22910         call to_box(xi,yi,zi)
22911
22912        do j=itmp+1,itmp+nres_molec(5)
22913 !           print *,"WTF",itmp,j,i
22914 ! all parameters were for Ca2+ to approximate single charge divide by two
22915        ndiv=1.0
22916        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
22917        wconst=78*ndiv
22918       wdip =1.092777950857032D2
22919       wdip=wdip/wconst
22920       wmodquad=-2.174122713004870D4
22921       wmodquad=wmodquad/wconst
22922       wquad1 = 3.901232068562804D1
22923       wquad1=wquad1/wconst
22924       wquad2 = 3
22925       wquad2=wquad2/wconst
22926       wvan1 = 0.1
22927       wvan2 = 6
22928 !        itmp=0
22929
22930          xj=c(1,j)
22931          yj=c(2,j)
22932          zj=c(3,j)
22933         call to_box(xj,yj,zj)
22934       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22935 !       enddo
22936 !       enddo
22937        rcpm = sqrt(xj**2+yj**2+zj**2)
22938        drcp_norm(1)=xj/rcpm
22939        drcp_norm(2)=yj/rcpm
22940        drcp_norm(3)=zj/rcpm
22941        dcmag=0.0
22942        do k=1,3
22943        dcmag=dcmag+dc(k,i)**2
22944        enddo
22945        dcmag=dsqrt(dcmag)
22946        do k=1,3
22947        myd_norm(k)=dc(k,i)/dcmag
22948        enddo
22949       costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
22950       drcp_norm(3)*myd_norm(3)
22951       rsecp = rcpm**2
22952       Ir = 1.0d0/rcpm
22953       Irsecp = 1.0d0/rsecp
22954       Irthrp = Irsecp/rcpm
22955       Irfourp = Irthrp/rcpm
22956       Irfiftp = Irfourp/rcpm
22957       Irsistp=Irfiftp/rcpm
22958       Irseven=Irsistp/rcpm
22959       Irtwelv=Irsistp*Irsistp
22960       Irthir=Irtwelv/rcpm
22961       sin2thet = (1-costhet*costhet)
22962       sinthet=sqrt(sin2thet)
22963       E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
22964            *sin2thet
22965       E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
22966            2*wvan2**6*Irsistp)
22967       ecation_prot = ecation_prot+E1+E2
22968 !        print *,"ecatprot",i,j,ecation_prot,rcpm
22969       dE1dr = -2*costhet*wdip*Irthrp-&
22970        (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
22971       dE2dr = 3*wquad1*wquad2*Irfourp-     &
22972         12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
22973       dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
22974       do k=1,3
22975         drdpep(k) = -drcp_norm(k)
22976         dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
22977         dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
22978         dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
22979         dEddci(k) = dEdcos*dcosddci(k)
22980       enddo
22981       do k=1,3
22982       gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
22983       gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
22984       gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
22985       enddo
22986        enddo ! j
22987        enddo ! i
22988 !------------------------------------------sidechains
22989 !        do i=1,nres_molec(1)
22990       do i=ibond_start,ibond_end
22991        if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
22992 !         cycle
22993 !        print *,i,ecation_prot
22994       xi=(c(1,i+nres))
22995       yi=(c(2,i+nres))
22996       zi=(c(3,i+nres))
22997                 call to_box(xi,yi,zi)
22998         do k=1,3
22999           cm1(k)=dc(k,i+nres)
23000         enddo
23001          cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
23002        do j=itmp+1,itmp+nres_molec(5)
23003        ndiv=1.0
23004        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23005
23006          xj=c(1,j)
23007          yj=c(2,j)
23008          zj=c(3,j)
23009         call to_box(xj,yj,zj)
23010       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23011 !       enddo
23012 !       enddo
23013 ! 15- Glu 16-Asp
23014        if((itype(i,1).eq.15.or.itype(i,1).eq.16).or.&
23015        ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.&
23016        (itype(i,1).eq.25))) then
23017           if(itype(i,1).eq.16) then
23018           inum=1
23019           else
23020           inum=2
23021           endif
23022           do k=1,6
23023           vcatprm(k)=catprm(k,inum)
23024           enddo
23025           dASGL=catprm(7,inum)
23026 !             do k=1,3
23027 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23028             vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23029             vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23030             vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23031
23032 !                valpha(k)=c(k,i)
23033 !                vcat(k)=c(k,j)
23034             if (subchap.eq.1) then
23035              vcat(1)=xj_temp
23036              vcat(2)=yj_temp
23037              vcat(3)=zj_temp
23038              else
23039             vcat(1)=xj_safe
23040             vcat(2)=yj_safe
23041             vcat(3)=zj_safe
23042              endif
23043             valpha(1)=xi-c(1,i+nres)+c(1,i)
23044             valpha(2)=yi-c(2,i+nres)+c(2,i)
23045             valpha(3)=zi-c(3,i+nres)+c(3,i)
23046
23047 !              enddo
23048       do k=1,3
23049         dx(k) = vcat(k)-vcm(k)
23050       enddo
23051       do k=1,3
23052         v1(k)=(vcm(k)-valpha(k))
23053         v2(k)=(vcat(k)-valpha(k))
23054       enddo
23055       v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23056       v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23057       v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23058
23059 !  The weights of the energy function calculated from
23060 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
23061         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23062           ndivi=0.5
23063         else
23064           ndivi=1.0
23065         endif
23066        ndiv=1.0
23067        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23068
23069       wh2o=78*ndivi*ndiv
23070       wc = vcatprm(1)
23071       wc=wc/wh2o
23072       wdip =vcatprm(2)
23073       wdip=wdip/wh2o
23074       wquad1 =vcatprm(3)
23075       wquad1=wquad1/wh2o
23076       wquad2 = vcatprm(4)
23077       wquad2=wquad2/wh2o
23078       wquad2p = 1.0d0-wquad2
23079       wvan1 = vcatprm(5)
23080       wvan2 =vcatprm(6)
23081       opt = dx(1)**2+dx(2)**2
23082       rsecp = opt+dx(3)**2
23083       rs = sqrt(rsecp)
23084       rthrp = rsecp*rs
23085       rfourp = rthrp*rs
23086       rsixp = rfourp*rsecp
23087       reight=rsixp*rsecp
23088       Ir = 1.0d0/rs
23089       Irsecp = 1.0d0/rsecp
23090       Irthrp = Irsecp/rs
23091       Irfourp = Irthrp/rs
23092       Irsixp = 1.0d0/rsixp
23093       Ireight=1.0d0/reight
23094       Irtw=Irsixp*Irsixp
23095       Irthir=Irtw/rs
23096       Irfourt=Irthir/rs
23097       opt1 = (4*rs*dx(3)*wdip)
23098       opt2 = 6*rsecp*wquad1*opt
23099       opt3 = wquad1*wquad2p*Irsixp
23100       opt4 = (wvan1*wvan2**12)
23101       opt5 = opt4*12*Irfourt
23102       opt6 = 2*wvan1*wvan2**6
23103       opt7 = 6*opt6*Ireight
23104       opt8 = wdip/v1m
23105       opt10 = wdip/v2m
23106       opt11 = (rsecp*v2m)**2
23107       opt12 = (rsecp*v1m)**2
23108       opt14 = (v1m*v2m*rsecp)**2
23109       opt15 = -wquad1/v2m**2
23110       opt16 = (rthrp*(v1m*v2m)**2)**2
23111       opt17 = (v1m**2*rthrp)**2
23112       opt18 = -wquad1/rthrp
23113       opt19 = (v1m**2*v2m**2)**2
23114       Ec = wc*Ir
23115       do k=1,3
23116         dEcCat(k) = -(dx(k)*wc)*Irthrp
23117         dEcCm(k)=(dx(k)*wc)*Irthrp
23118         dEcCalp(k)=0.0d0
23119       enddo
23120       Edip=opt8*(v1dpv2)/(rsecp*v2m)
23121       do k=1,3
23122         dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
23123                  *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23124         dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
23125                 *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23126         dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
23127                   *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
23128                   *v1dpv2)/opt14
23129       enddo
23130       Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23131       do k=1,3
23132         dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
23133                    (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
23134                    v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23135         dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
23136                   (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
23137                   v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23138         dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23139                   v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
23140                   v1dpv2**2)/opt19
23141       enddo
23142       Equad2=wquad1*wquad2p*Irthrp
23143       do k=1,3
23144         dEquad2Cat(k)=-3*dx(k)*rs*opt3
23145         dEquad2Cm(k)=3*dx(k)*rs*opt3
23146         dEquad2Calp(k)=0.0d0
23147       enddo
23148       Evan1=opt4*Irtw
23149       do k=1,3
23150         dEvan1Cat(k)=-dx(k)*opt5
23151         dEvan1Cm(k)=dx(k)*opt5
23152         dEvan1Calp(k)=0.0d0
23153       enddo
23154       Evan2=-opt6*Irsixp
23155       do k=1,3
23156         dEvan2Cat(k)=dx(k)*opt7
23157         dEvan2Cm(k)=-dx(k)*opt7
23158         dEvan2Calp(k)=0.0d0
23159       enddo
23160       ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
23161 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
23162
23163       do k=1,3
23164         dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
23165                    dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23166 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
23167         dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
23168                   dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23169         dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
23170                   +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23171       enddo
23172           dscmag = 0.0d0
23173           do k=1,3
23174             dscvec(k) = dc(k,i+nres)
23175             dscmag = dscmag+dscvec(k)*dscvec(k)
23176           enddo
23177           dscmag3 = dscmag
23178           dscmag = sqrt(dscmag)
23179           dscmag3 = dscmag3*dscmag
23180           constA = 1.0d0+dASGL/dscmag
23181           constB = 0.0d0
23182           do k=1,3
23183             constB = constB+dscvec(k)*dEtotalCm(k)
23184           enddo
23185           constB = constB*dASGL/dscmag3
23186           do k=1,3
23187             gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23188             gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23189              constA*dEtotalCm(k)-constB*dscvec(k)
23190 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
23191             gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23192             gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23193            enddo
23194       else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
23195          if(itype(i,1).eq.14) then
23196           inum=3
23197           else
23198           inum=4
23199           endif
23200           do k=1,6
23201           vcatprm(k)=catprm(k,inum)
23202           enddo
23203           dASGL=catprm(7,inum)
23204 !             do k=1,3
23205 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23206 !                valpha(k)=c(k,i)
23207 !                vcat(k)=c(k,j)
23208 !              enddo
23209             vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23210             vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23211             vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23212             if (subchap.eq.1) then
23213              vcat(1)=xj_temp
23214              vcat(2)=yj_temp
23215              vcat(3)=zj_temp
23216              else
23217             vcat(1)=xj_safe
23218             vcat(2)=yj_safe
23219             vcat(3)=zj_safe
23220             endif
23221             valpha(1)=xi-c(1,i+nres)+c(1,i)
23222             valpha(2)=yi-c(2,i+nres)+c(2,i)
23223             valpha(3)=zi-c(3,i+nres)+c(3,i)
23224
23225
23226       do k=1,3
23227         dx(k) = vcat(k)-vcm(k)
23228       enddo
23229       do k=1,3
23230         v1(k)=(vcm(k)-valpha(k))
23231         v2(k)=(vcat(k)-valpha(k))
23232       enddo
23233       v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23234       v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23235       v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23236 !  The weights of the energy function calculated from
23237 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
23238        ndiv=1.0
23239        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23240
23241       wh2o=78*ndiv
23242       wdip =vcatprm(2)
23243       wdip=wdip/wh2o
23244       wquad1 =vcatprm(3)
23245       wquad1=wquad1/wh2o
23246       wquad2 = vcatprm(4)
23247       wquad2=wquad2/wh2o
23248       wquad2p = 1-wquad2
23249       wvan1 = vcatprm(5)
23250       wvan2 =vcatprm(6)
23251       opt = dx(1)**2+dx(2)**2
23252       rsecp = opt+dx(3)**2
23253       rs = sqrt(rsecp)
23254       rthrp = rsecp*rs
23255       rfourp = rthrp*rs
23256       rsixp = rfourp*rsecp
23257       reight=rsixp*rsecp
23258       Ir = 1.0d0/rs
23259       Irsecp = 1/rsecp
23260       Irthrp = Irsecp/rs
23261       Irfourp = Irthrp/rs
23262       Irsixp = 1/rsixp
23263       Ireight=1/reight
23264       Irtw=Irsixp*Irsixp
23265       Irthir=Irtw/rs
23266       Irfourt=Irthir/rs
23267       opt1 = (4*rs*dx(3)*wdip)
23268       opt2 = 6*rsecp*wquad1*opt
23269       opt3 = wquad1*wquad2p*Irsixp
23270       opt4 = (wvan1*wvan2**12)
23271       opt5 = opt4*12*Irfourt
23272       opt6 = 2*wvan1*wvan2**6
23273       opt7 = 6*opt6*Ireight
23274       opt8 = wdip/v1m
23275       opt10 = wdip/v2m
23276       opt11 = (rsecp*v2m)**2
23277       opt12 = (rsecp*v1m)**2
23278       opt14 = (v1m*v2m*rsecp)**2
23279       opt15 = -wquad1/v2m**2
23280       opt16 = (rthrp*(v1m*v2m)**2)**2
23281       opt17 = (v1m**2*rthrp)**2
23282       opt18 = -wquad1/rthrp
23283       opt19 = (v1m**2*v2m**2)**2
23284       Edip=opt8*(v1dpv2)/(rsecp*v2m)
23285       do k=1,3
23286         dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
23287                  *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23288        dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
23289                 *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23290         dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
23291                   *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
23292                   *v1dpv2)/opt14
23293       enddo
23294       Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23295       do k=1,3
23296         dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
23297                    (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
23298                    v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23299         dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
23300                   (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
23301                    v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23302         dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23303                   v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
23304                   v1dpv2**2)/opt19
23305       enddo
23306       Equad2=wquad1*wquad2p*Irthrp
23307       do k=1,3
23308         dEquad2Cat(k)=-3*dx(k)*rs*opt3
23309         dEquad2Cm(k)=3*dx(k)*rs*opt3
23310         dEquad2Calp(k)=0.0d0
23311       enddo
23312       Evan1=opt4*Irtw
23313       do k=1,3
23314         dEvan1Cat(k)=-dx(k)*opt5
23315         dEvan1Cm(k)=dx(k)*opt5
23316         dEvan1Calp(k)=0.0d0
23317       enddo
23318       Evan2=-opt6*Irsixp
23319       do k=1,3
23320         dEvan2Cat(k)=dx(k)*opt7
23321         dEvan2Cm(k)=-dx(k)*opt7
23322         dEvan2Calp(k)=0.0d0
23323       enddo
23324        ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
23325       do k=1,3
23326         dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
23327                    dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23328         dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
23329                   dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23330         dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
23331                   +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23332       enddo
23333           dscmag = 0.0d0
23334           do k=1,3
23335             dscvec(k) = c(k,i+nres)-c(k,i)
23336 ! TU SPRAWDZ???
23337 !              dscvec(1) = xj
23338 !              dscvec(2) = yj
23339 !              dscvec(3) = zj
23340
23341             dscmag = dscmag+dscvec(k)*dscvec(k)
23342           enddo
23343           dscmag3 = dscmag
23344           dscmag = sqrt(dscmag)
23345           dscmag3 = dscmag3*dscmag
23346           constA = 1+dASGL/dscmag
23347           constB = 0.0d0
23348           do k=1,3
23349             constB = constB+dscvec(k)*dEtotalCm(k)
23350           enddo
23351           constB = constB*dASGL/dscmag3
23352           do k=1,3
23353             gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23354             gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23355              constA*dEtotalCm(k)-constB*dscvec(k)
23356             gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23357             gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23358            enddo
23359          else
23360           rcal = 0.0d0
23361           do k=1,3
23362 !              r(k) = c(k,j)-c(k,i+nres)
23363             r(1) = xj
23364             r(2) = yj
23365             r(3) = zj
23366             rcal = rcal+r(k)*r(k)
23367           enddo
23368           ract=sqrt(rcal)
23369           rocal=1.5
23370           epscalc=0.2
23371           r0p=0.5*(rocal+sig0(itype(i,1)))
23372           r06 = r0p**6
23373           r012 = r06*r06
23374           Evan1=epscalc*(r012/rcal**6)
23375           Evan2=epscalc*2*(r06/rcal**3)
23376           r4 = rcal**4
23377           r7 = rcal**7
23378           do k=1,3
23379             dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
23380             dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
23381           enddo
23382           do k=1,3
23383             dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
23384           enddo
23385              ecation_prot = ecation_prot+ Evan1+Evan2
23386           do  k=1,3
23387              gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23388              dEtotalCm(k)
23389             gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
23390             gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
23391            enddo
23392        endif ! 13-16 residues
23393        enddo !j
23394        enddo !i
23395        return
23396        end subroutine ecat_prot
23397
23398 !----------------------------------------------------------------------------
23399 !-----------------------------------------------------------------------------
23400 !-----------------------------------------------------------------------------
23401       subroutine eprot_sc_base(escbase)
23402       use calc_data
23403 !      implicit real*8 (a-h,o-z)
23404 !      include 'DIMENSIONS'
23405 !      include 'COMMON.GEO'
23406 !      include 'COMMON.VAR'
23407 !      include 'COMMON.LOCAL'
23408 !      include 'COMMON.CHAIN'
23409 !      include 'COMMON.DERIV'
23410 !      include 'COMMON.NAMES'
23411 !      include 'COMMON.INTERACT'
23412 !      include 'COMMON.IOUNITS'
23413 !      include 'COMMON.CALC'
23414 !      include 'COMMON.CONTROL'
23415 !      include 'COMMON.SBRIDGE'
23416       logical :: lprn
23417 !el local variables
23418       integer :: iint,itypi,itypi1,itypj,subchap
23419       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23420       real(kind=8) :: evdw,sig0ij
23421       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23422                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23423                 sslipi,sslipj,faclip
23424       integer :: ii
23425       real(kind=8) :: fracinbuf
23426        real (kind=8) :: escbase
23427        real (kind=8),dimension(4):: ener
23428        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23429        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23430       sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
23431       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23432       dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
23433       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23434       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23435       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
23436        real(kind=8),dimension(3,2)::chead,erhead_tail
23437        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23438        integer troll
23439        eps_out=80.0d0
23440        escbase=0.0d0
23441 !       do i=1,nres_molec(1)
23442       do i=ibond_start,ibond_end
23443       if (itype(i,1).eq.ntyp1_molec(1)) cycle
23444       itypi  = itype(i,1)
23445       dxi    = dc_norm(1,nres+i)
23446       dyi    = dc_norm(2,nres+i)
23447       dzi    = dc_norm(3,nres+i)
23448       dsci_inv = vbld_inv(i+nres)
23449       xi=c(1,nres+i)
23450       yi=c(2,nres+i)
23451       zi=c(3,nres+i)
23452       call to_box(xi,yi,zi)
23453       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
23454        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
23455          itypj= itype(j,2)
23456          if (itype(j,2).eq.ntyp1_molec(2))cycle
23457          xj=c(1,j+nres)
23458          yj=c(2,j+nres)
23459          zj=c(3,j+nres)
23460       call to_box(xj,yj,zj)
23461       call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
23462       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23463        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23464       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23465        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23466       xj=boxshift(xj-xi,boxxsize)
23467       yj=boxshift(yj-yi,boxysize)
23468       zj=boxshift(zj-zi,boxzsize)
23469
23470         dxj = dc_norm( 1, nres+j )
23471         dyj = dc_norm( 2, nres+j )
23472         dzj = dc_norm( 3, nres+j )
23473 !          print *,i,j,itypi,itypj
23474         d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
23475         d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
23476 !          d1i=0.0d0
23477 !          d1j=0.0d0
23478 !          BetaT = 1.0d0 / (298.0d0 * Rb)
23479 ! Gay-berne var's
23480         sig0ij = sigma_scbase( itypi,itypj )
23481         chi1   = chi_scbase( itypi, itypj,1 )
23482         chi2   = chi_scbase( itypi, itypj,2 )
23483 !          chi1=0.0d0
23484 !          chi2=0.0d0
23485         chi12  = chi1 * chi2
23486         chip1  = chipp_scbase( itypi, itypj,1 )
23487         chip2  = chipp_scbase( itypi, itypj,2 )
23488 !          chip1=0.0d0
23489 !          chip2=0.0d0
23490         chip12 = chip1 * chip2
23491 ! not used by momo potential, but needed by sc_angular which is shared
23492 ! by all energy_potential subroutines
23493         alf1   = 0.0d0
23494         alf2   = 0.0d0
23495         alf12  = 0.0d0
23496         a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
23497 !       a12sq = a12sq * a12sq
23498 ! charge of amino acid itypi is...
23499         chis1 = chis_scbase(itypi,itypj,1)
23500         chis2 = chis_scbase(itypi,itypj,2)
23501         chis12 = chis1 * chis2
23502         sig1 = sigmap1_scbase(itypi,itypj)
23503         sig2 = sigmap2_scbase(itypi,itypj)
23504 !       write (*,*) "sig1 = ", sig1
23505 !       write (*,*) "sig2 = ", sig2
23506 ! alpha factors from Fcav/Gcav
23507         b1 = alphasur_scbase(1,itypi,itypj)
23508 !          b1=0.0d0
23509         b2 = alphasur_scbase(2,itypi,itypj)
23510         b3 = alphasur_scbase(3,itypi,itypj)
23511         b4 = alphasur_scbase(4,itypi,itypj)
23512 ! used to determine whether we want to do quadrupole calculations
23513 ! used by Fgb
23514        eps_in = epsintab_scbase(itypi,itypj)
23515        if (eps_in.eq.0.0) eps_in=1.0
23516        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23517 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
23518 !-------------------------------------------------------------------
23519 ! tail location and distance calculations
23520        DO k = 1,3
23521 ! location of polar head is computed by taking hydrophobic centre
23522 ! and moving by a d1 * dc_norm vector
23523 ! see unres publications for very informative images
23524       chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
23525       chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
23526 ! distance
23527 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23528 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23529       Rhead_distance(k) = chead(k,2) - chead(k,1)
23530        END DO
23531 ! pitagoras (root of sum of squares)
23532        Rhead = dsqrt( &
23533         (Rhead_distance(1)*Rhead_distance(1)) &
23534       + (Rhead_distance(2)*Rhead_distance(2)) &
23535       + (Rhead_distance(3)*Rhead_distance(3)))
23536 !-------------------------------------------------------------------
23537 ! zero everything that should be zero'ed
23538        evdwij = 0.0d0
23539        ECL = 0.0d0
23540        Elj = 0.0d0
23541        Equad = 0.0d0
23542        Epol = 0.0d0
23543        Fcav=0.0d0
23544        eheadtail = 0.0d0
23545        dGCLdOM1 = 0.0d0
23546        dGCLdOM2 = 0.0d0
23547        dGCLdOM12 = 0.0d0
23548        dPOLdOM1 = 0.0d0
23549        dPOLdOM2 = 0.0d0
23550         Fcav = 0.0d0
23551         dFdR = 0.0d0
23552         dCAVdOM1  = 0.0d0
23553         dCAVdOM2  = 0.0d0
23554         dCAVdOM12 = 0.0d0
23555         dscj_inv = vbld_inv(j+nres)
23556 !          print *,i,j,dscj_inv,dsci_inv
23557 ! rij holds 1/(distance of Calpha atoms)
23558         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23559         rij  = dsqrt(rrij)
23560 !----------------------------
23561         CALL sc_angular
23562 ! this should be in elgrad_init but om's are calculated by sc_angular
23563 ! which in turn is used by older potentials
23564 ! om = omega, sqom = om^2
23565         sqom1  = om1 * om1
23566         sqom2  = om2 * om2
23567         sqom12 = om12 * om12
23568
23569 ! now we calculate EGB - Gey-Berne
23570 ! It will be summed up in evdwij and saved in evdw
23571         sigsq     = 1.0D0  / sigsq
23572         sig       = sig0ij * dsqrt(sigsq)
23573 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23574         rij_shift = 1.0/rij - sig + sig0ij
23575         IF (rij_shift.le.0.0D0) THEN
23576          evdw = 1.0D20
23577          RETURN
23578         END IF
23579         sigder = -sig * sigsq
23580         rij_shift = 1.0D0 / rij_shift
23581         fac       = rij_shift**expon
23582         c1        = fac  * fac * aa_scbase(itypi,itypj)
23583 !          c1        = 0.0d0
23584         c2        = fac  * bb_scbase(itypi,itypj)
23585 !          c2        = 0.0d0
23586         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23587         eps2der   = eps3rt * evdwij
23588         eps3der   = eps2rt * evdwij
23589 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23590         evdwij    = eps2rt * eps3rt * evdwij
23591         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23592         fac    = -expon * (c1 + evdwij) * rij_shift
23593         sigder = fac * sigder
23594 !          fac    = rij * fac
23595 ! Calculate distance derivative
23596         gg(1) =  fac
23597         gg(2) =  fac
23598         gg(3) =  fac
23599 !          if (b2.gt.0.0) then
23600         fac = chis1 * sqom1 + chis2 * sqom2 &
23601         - 2.0d0 * chis12 * om1 * om2 * om12
23602 ! we will use pom later in Gcav, so dont mess with it!
23603         pom = 1.0d0 - chis1 * chis2 * sqom12
23604         Lambf = (1.0d0 - (fac / pom))
23605         Lambf = dsqrt(Lambf)
23606         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23607 !       write (*,*) "sparrow = ", sparrow
23608         Chif = 1.0d0/rij * sparrow
23609         ChiLambf = Chif * Lambf
23610         eagle = dsqrt(ChiLambf)
23611         bat = ChiLambf ** 11.0d0
23612         top = b1 * ( eagle + b2 * ChiLambf - b3 )
23613         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23614         botsq = bot * bot
23615         Fcav = top / bot
23616 !          print *,i,j,Fcav
23617         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23618         dbot = 12.0d0 * b4 * bat * Lambf
23619         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23620 !       dFdR = 0.0d0
23621 !      write (*,*) "dFcav/dR = ", dFdR
23622         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23623         dbot = 12.0d0 * b4 * bat * Chif
23624         eagle = Lambf * pom
23625         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23626         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23627         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23628             * (chis2 * om2 * om12 - om1) / (eagle * pom)
23629
23630         dFdL = ((dtop * bot - top * dbot) / botsq)
23631 !       dFdL = 0.0d0
23632         dCAVdOM1  = dFdL * ( dFdOM1 )
23633         dCAVdOM2  = dFdL * ( dFdOM2 )
23634         dCAVdOM12 = dFdL * ( dFdOM12 )
23635
23636         ertail(1) = xj*rij
23637         ertail(2) = yj*rij
23638         ertail(3) = zj*rij
23639 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
23640 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
23641 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
23642 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
23643 !           print *,"EOMY",eom1,eom2,eom12
23644 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
23645 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
23646 ! here dtail=0.0
23647 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
23648 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23649        DO k = 1, 3
23650 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23651 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23652       pom = ertail(k)
23653 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23654       gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
23655               - (( dFdR + gg(k) ) * pom)
23656 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23657 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23658 !     &             - ( dFdR * pom )
23659       pom = ertail(k)
23660 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23661       gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
23662               + (( dFdR + gg(k) ) * pom)
23663 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23664 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23665 !c!     &             + ( dFdR * pom )
23666
23667       gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
23668               - (( dFdR + gg(k) ) * ertail(k))
23669 !c!     &             - ( dFdR * ertail(k))
23670
23671       gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
23672               + (( dFdR + gg(k) ) * ertail(k))
23673 !c!     &             + ( dFdR * ertail(k))
23674
23675       gg(k) = 0.0d0
23676 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23677 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23678       END DO
23679
23680 !          else
23681
23682 !          endif
23683 !Now dipole-dipole
23684        if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
23685        w1 = wdipdip_scbase(1,itypi,itypj)
23686        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
23687        w3 = wdipdip_scbase(2,itypi,itypj)
23688 !c!-------------------------------------------------------------------
23689 !c! ECL
23690        fac = (om12 - 3.0d0 * om1 * om2)
23691        c1 = (w1 / (Rhead**3.0d0)) * fac
23692        c2 = (w2 / Rhead ** 6.0d0)  &
23693        * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23694        c3= (w3/ Rhead ** 6.0d0)  &
23695        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23696        ECL = c1 - c2 + c3
23697 !c!       write (*,*) "w1 = ", w1
23698 !c!       write (*,*) "w2 = ", w2
23699 !c!       write (*,*) "om1 = ", om1
23700 !c!       write (*,*) "om2 = ", om2
23701 !c!       write (*,*) "om12 = ", om12
23702 !c!       write (*,*) "fac = ", fac
23703 !c!       write (*,*) "c1 = ", c1
23704 !c!       write (*,*) "c2 = ", c2
23705 !c!       write (*,*) "Ecl = ", Ecl
23706 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
23707 !c!       write (*,*) "c2_2 = ",
23708 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23709 !c!-------------------------------------------------------------------
23710 !c! dervative of ECL is GCL...
23711 !c! dECL/dr
23712        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
23713        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
23714        * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
23715        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
23716        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23717        dGCLdR = c1 - c2 + c3
23718 !c! dECL/dom1
23719        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
23720        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23721        * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
23722        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
23723        dGCLdOM1 = c1 - c2 + c3
23724 !c! dECL/dom2
23725        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
23726        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23727        * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
23728        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
23729        dGCLdOM2 = c1 - c2 + c3
23730 !c! dECL/dom12
23731        c1 = w1 / (Rhead ** 3.0d0)
23732        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
23733        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
23734        dGCLdOM12 = c1 - c2 + c3
23735        DO k= 1, 3
23736       erhead(k) = Rhead_distance(k)/Rhead
23737        END DO
23738        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23739        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
23740        facd1 = d1i * vbld_inv(i+nres)
23741        facd2 = d1j * vbld_inv(j+nres)
23742        DO k = 1, 3
23743
23744       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23745       gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
23746               - dGCLdR * pom
23747       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
23748       gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
23749               + dGCLdR * pom
23750
23751       gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
23752               - dGCLdR * erhead(k)
23753       gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
23754               + dGCLdR * erhead(k)
23755        END DO
23756        endif
23757 !now charge with dipole eg. ARG-dG
23758        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
23759       alphapol1 = alphapol_scbase(itypi,itypj)
23760        w1        = wqdip_scbase(1,itypi,itypj)
23761        w2        = wqdip_scbase(2,itypi,itypj)
23762 !       w1=0.0d0
23763 !       w2=0.0d0
23764 !       pis       = sig0head_scbase(itypi,itypj)
23765 !       eps_head   = epshead_scbase(itypi,itypj)
23766 !c!-------------------------------------------------------------------
23767 !c! R1 - distance between head of ith side chain and tail of jth sidechain
23768        R1 = 0.0d0
23769        DO k = 1, 3
23770 !c! Calculate head-to-tail distances tail is center of side-chain
23771       R1=R1+(c(k,j+nres)-chead(k,1))**2
23772        END DO
23773 !c! Pitagoras
23774        R1 = dsqrt(R1)
23775
23776 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
23777 !c!     &        +dhead(1,1,itypi,itypj))**2))
23778 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
23779 !c!     &        +dhead(2,1,itypi,itypj))**2))
23780
23781 !c!-------------------------------------------------------------------
23782 !c! ecl
23783        sparrow  = w1  *  om1
23784        hawk     = w2 *  (1.0d0 - sqom2)
23785        Ecl = sparrow / Rhead**2.0d0 &
23786          - hawk    / Rhead**4.0d0
23787 !c!-------------------------------------------------------------------
23788 !c! derivative of ecl is Gcl
23789 !c! dF/dr part
23790        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
23791             + 4.0d0 * hawk    / Rhead**5.0d0
23792 !c! dF/dom1
23793        dGCLdOM1 = (w1) / (Rhead**2.0d0)
23794 !c! dF/dom2
23795        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
23796 !c--------------------------------------------------------------------
23797 !c Polarization energy
23798 !c Epol
23799        MomoFac1 = (1.0d0 - chi1 * sqom2)
23800        RR1  = R1 * R1 / MomoFac1
23801        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
23802        fgb1 = sqrt( RR1 + a12sq * ee1)
23803 !       eps_inout_fac=0.0d0
23804        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
23805 ! derivative of Epol is Gpol...
23806        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
23807             / (fgb1 ** 5.0d0)
23808        dFGBdR1 = ( (R1 / MomoFac1) &
23809            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
23810            / ( 2.0d0 * fgb1 )
23811        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
23812              * (2.0d0 - 0.5d0 * ee1) ) &
23813              / (2.0d0 * fgb1)
23814        dPOLdR1 = dPOLdFGB1 * dFGBdR1
23815 !       dPOLdR1 = 0.0d0
23816        dPOLdOM1 = 0.0d0
23817        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
23818        DO k = 1, 3
23819       erhead(k) = Rhead_distance(k)/Rhead
23820       erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
23821        END DO
23822
23823        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23824        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
23825        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
23826 !       bat=0.0d0
23827        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
23828        facd1 = d1i * vbld_inv(i+nres)
23829        facd2 = d1j * vbld_inv(j+nres)
23830 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23831
23832        DO k = 1, 3
23833       hawk = (erhead_tail(k,1) + &
23834       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
23835 !        facd1=0.0d0
23836 !        facd2=0.0d0
23837       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23838       gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
23839                - dGCLdR * pom &
23840                - dPOLdR1 *  (erhead_tail(k,1))
23841 !     &             - dGLJdR * pom
23842
23843       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
23844       gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
23845                + dGCLdR * pom  &
23846                + dPOLdR1 * (erhead_tail(k,1))
23847 !     &             + dGLJdR * pom
23848
23849
23850       gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
23851               - dGCLdR * erhead(k) &
23852               - dPOLdR1 * erhead_tail(k,1)
23853 !     &             - dGLJdR * erhead(k)
23854
23855       gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
23856               + dGCLdR * erhead(k)  &
23857               + dPOLdR1 * erhead_tail(k,1)
23858 !     &             + dGLJdR * erhead(k)
23859
23860        END DO
23861        endif
23862 !       print *,i,j,evdwij,epol,Fcav,ECL
23863        escbase=escbase+evdwij+epol+Fcav+ECL
23864        call sc_grad_scbase
23865        enddo
23866       enddo
23867
23868       return
23869       end subroutine eprot_sc_base
23870       SUBROUTINE sc_grad_scbase
23871       use calc_data
23872
23873        real (kind=8) :: dcosom1(3),dcosom2(3)
23874        eom1  =    &
23875             eps2der * eps2rt_om1   &
23876           - 2.0D0 * alf1 * eps3der &
23877           + sigder * sigsq_om1     &
23878           + dCAVdOM1               &
23879           + dGCLdOM1               &
23880           + dPOLdOM1
23881
23882        eom2  =  &
23883             eps2der * eps2rt_om2   &
23884           + 2.0D0 * alf2 * eps3der &
23885           + sigder * sigsq_om2     &
23886           + dCAVdOM2               &
23887           + dGCLdOM2               &
23888           + dPOLdOM2
23889
23890        eom12 =    &
23891             evdwij  * eps1_om12     &
23892           + eps2der * eps2rt_om12   &
23893           - 2.0D0 * alf12 * eps3der &
23894           + sigder *sigsq_om12      &
23895           + dCAVdOM12               &
23896           + dGCLdOM12
23897
23898 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23899 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23900 !               gg(1),gg(2),"rozne"
23901        DO k = 1, 3
23902       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
23903       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
23904       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23905       gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
23906              + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23907              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23908       gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
23909              + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23910              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23911       gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
23912       gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
23913        END DO
23914        RETURN
23915       END SUBROUTINE sc_grad_scbase
23916
23917
23918       subroutine epep_sc_base(epepbase)
23919       use calc_data
23920       logical :: lprn
23921 !el local variables
23922       integer :: iint,itypi,itypi1,itypj,subchap
23923       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23924       real(kind=8) :: evdw,sig0ij
23925       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23926                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23927                 sslipi,sslipj,faclip
23928       integer :: ii
23929       real(kind=8) :: fracinbuf
23930        real (kind=8) :: epepbase
23931        real (kind=8),dimension(4):: ener
23932        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23933        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23934       sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
23935       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23936       dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
23937       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23938       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23939       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
23940        real(kind=8),dimension(3,2)::chead,erhead_tail
23941        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23942        integer troll
23943        eps_out=80.0d0
23944        epepbase=0.0d0
23945 !       do i=1,nres_molec(1)-1
23946       do i=ibond_start,ibond_end
23947       if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
23948 !C        itypi  = itype(i,1)
23949       dxi    = dc_norm(1,i)
23950       dyi    = dc_norm(2,i)
23951       dzi    = dc_norm(3,i)
23952 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
23953       dsci_inv = vbld_inv(i+1)/2.0
23954       xi=(c(1,i)+c(1,i+1))/2.0
23955       yi=(c(2,i)+c(2,i+1))/2.0
23956       zi=(c(3,i)+c(3,i+1))/2.0
23957         call to_box(xi,yi,zi)
23958        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
23959          itypj= itype(j,2)
23960          if (itype(j,2).eq.ntyp1_molec(2))cycle
23961          xj=c(1,j+nres)
23962          yj=c(2,j+nres)
23963          zj=c(3,j+nres)
23964                 call to_box(xj,yj,zj)
23965       xj=boxshift(xj-xi,boxxsize)
23966       yj=boxshift(yj-yi,boxysize)
23967       zj=boxshift(zj-zi,boxzsize)
23968         dist_init=xj**2+yj**2+zj**2
23969         dxj = dc_norm( 1, nres+j )
23970         dyj = dc_norm( 2, nres+j )
23971         dzj = dc_norm( 3, nres+j )
23972 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
23973 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
23974
23975 ! Gay-berne var's
23976         sig0ij = sigma_pepbase(itypj )
23977         chi1   = chi_pepbase(itypj,1 )
23978         chi2   = chi_pepbase(itypj,2 )
23979 !          chi1=0.0d0
23980 !          chi2=0.0d0
23981         chi12  = chi1 * chi2
23982         chip1  = chipp_pepbase(itypj,1 )
23983         chip2  = chipp_pepbase(itypj,2 )
23984 !          chip1=0.0d0
23985 !          chip2=0.0d0
23986         chip12 = chip1 * chip2
23987         chis1 = chis_pepbase(itypj,1)
23988         chis2 = chis_pepbase(itypj,2)
23989         chis12 = chis1 * chis2
23990         sig1 = sigmap1_pepbase(itypj)
23991         sig2 = sigmap2_pepbase(itypj)
23992 !       write (*,*) "sig1 = ", sig1
23993 !       write (*,*) "sig2 = ", sig2
23994        DO k = 1,3
23995 ! location of polar head is computed by taking hydrophobic centre
23996 ! and moving by a d1 * dc_norm vector
23997 ! see unres publications for very informative images
23998       chead(k,1) = (c(k,i)+c(k,i+1))/2.0
23999 ! + d1i * dc_norm(k, i+nres)
24000       chead(k,2) = c(k, j+nres)
24001 ! + d1j * dc_norm(k, j+nres)
24002 ! distance
24003 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24004 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24005       Rhead_distance(k) = chead(k,2) - chead(k,1)
24006 !        print *,gvdwc_pepbase(k,i)
24007
24008        END DO
24009        Rhead = dsqrt( &
24010         (Rhead_distance(1)*Rhead_distance(1)) &
24011       + (Rhead_distance(2)*Rhead_distance(2)) &
24012       + (Rhead_distance(3)*Rhead_distance(3)))
24013
24014 ! alpha factors from Fcav/Gcav
24015         b1 = alphasur_pepbase(1,itypj)
24016 !          b1=0.0d0
24017         b2 = alphasur_pepbase(2,itypj)
24018         b3 = alphasur_pepbase(3,itypj)
24019         b4 = alphasur_pepbase(4,itypj)
24020         alf1   = 0.0d0
24021         alf2   = 0.0d0
24022         alf12  = 0.0d0
24023         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24024 !          print *,i,j,rrij
24025         rij  = dsqrt(rrij)
24026 !----------------------------
24027        evdwij = 0.0d0
24028        ECL = 0.0d0
24029        Elj = 0.0d0
24030        Equad = 0.0d0
24031        Epol = 0.0d0
24032        Fcav=0.0d0
24033        eheadtail = 0.0d0
24034        dGCLdOM1 = 0.0d0
24035        dGCLdOM2 = 0.0d0
24036        dGCLdOM12 = 0.0d0
24037        dPOLdOM1 = 0.0d0
24038        dPOLdOM2 = 0.0d0
24039         Fcav = 0.0d0
24040         dFdR = 0.0d0
24041         dCAVdOM1  = 0.0d0
24042         dCAVdOM2  = 0.0d0
24043         dCAVdOM12 = 0.0d0
24044         dscj_inv = vbld_inv(j+nres)
24045         CALL sc_angular
24046 ! this should be in elgrad_init but om's are calculated by sc_angular
24047 ! which in turn is used by older potentials
24048 ! om = omega, sqom = om^2
24049         sqom1  = om1 * om1
24050         sqom2  = om2 * om2
24051         sqom12 = om12 * om12
24052
24053 ! now we calculate EGB - Gey-Berne
24054 ! It will be summed up in evdwij and saved in evdw
24055         sigsq     = 1.0D0  / sigsq
24056         sig       = sig0ij * dsqrt(sigsq)
24057         rij_shift = 1.0/rij - sig + sig0ij
24058         IF (rij_shift.le.0.0D0) THEN
24059          evdw = 1.0D20
24060          RETURN
24061         END IF
24062         sigder = -sig * sigsq
24063         rij_shift = 1.0D0 / rij_shift
24064         fac       = rij_shift**expon
24065         c1        = fac  * fac * aa_pepbase(itypj)
24066 !          c1        = 0.0d0
24067         c2        = fac  * bb_pepbase(itypj)
24068 !          c2        = 0.0d0
24069         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24070         eps2der   = eps3rt * evdwij
24071         eps3der   = eps2rt * evdwij
24072 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24073         evdwij    = eps2rt * eps3rt * evdwij
24074         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24075         fac    = -expon * (c1 + evdwij) * rij_shift
24076         sigder = fac * sigder
24077 !          fac    = rij * fac
24078 ! Calculate distance derivative
24079         gg(1) =  fac
24080         gg(2) =  fac
24081         gg(3) =  fac
24082         fac = chis1 * sqom1 + chis2 * sqom2 &
24083         - 2.0d0 * chis12 * om1 * om2 * om12
24084 ! we will use pom later in Gcav, so dont mess with it!
24085         pom = 1.0d0 - chis1 * chis2 * sqom12
24086         Lambf = (1.0d0 - (fac / pom))
24087         Lambf = dsqrt(Lambf)
24088         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24089 !       write (*,*) "sparrow = ", sparrow
24090         Chif = 1.0d0/rij * sparrow
24091         ChiLambf = Chif * Lambf
24092         eagle = dsqrt(ChiLambf)
24093         bat = ChiLambf ** 11.0d0
24094         top = b1 * ( eagle + b2 * ChiLambf - b3 )
24095         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24096         botsq = bot * bot
24097         Fcav = top / bot
24098 !          print *,i,j,Fcav
24099         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24100         dbot = 12.0d0 * b4 * bat * Lambf
24101         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24102 !       dFdR = 0.0d0
24103 !      write (*,*) "dFcav/dR = ", dFdR
24104         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24105         dbot = 12.0d0 * b4 * bat * Chif
24106         eagle = Lambf * pom
24107         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24108         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24109         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24110             * (chis2 * om2 * om12 - om1) / (eagle * pom)
24111
24112         dFdL = ((dtop * bot - top * dbot) / botsq)
24113 !       dFdL = 0.0d0
24114         dCAVdOM1  = dFdL * ( dFdOM1 )
24115         dCAVdOM2  = dFdL * ( dFdOM2 )
24116         dCAVdOM12 = dFdL * ( dFdOM12 )
24117
24118         ertail(1) = xj*rij
24119         ertail(2) = yj*rij
24120         ertail(3) = zj*rij
24121        DO k = 1, 3
24122 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24123 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24124       pom = ertail(k)
24125 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24126       gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24127               - (( dFdR + gg(k) ) * pom)/2.0
24128 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
24129 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24130 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24131 !     &             - ( dFdR * pom )
24132       pom = ertail(k)
24133 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24134       gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24135               + (( dFdR + gg(k) ) * pom)
24136 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24137 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24138 !c!     &             + ( dFdR * pom )
24139
24140       gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24141               - (( dFdR + gg(k) ) * ertail(k))/2.0
24142 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
24143
24144 !c!     &             - ( dFdR * ertail(k))
24145
24146       gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24147               + (( dFdR + gg(k) ) * ertail(k))
24148 !c!     &             + ( dFdR * ertail(k))
24149
24150       gg(k) = 0.0d0
24151 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24152 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24153       END DO
24154
24155
24156        w1 = wdipdip_pepbase(1,itypj)
24157        w2 = -wdipdip_pepbase(3,itypj)/2.0
24158        w3 = wdipdip_pepbase(2,itypj)
24159 !       w1=0.0d0
24160 !       w2=0.0d0
24161 !c!-------------------------------------------------------------------
24162 !c! ECL
24163 !       w3=0.0d0
24164        fac = (om12 - 3.0d0 * om1 * om2)
24165        c1 = (w1 / (Rhead**3.0d0)) * fac
24166        c2 = (w2 / Rhead ** 6.0d0)  &
24167        * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24168        c3= (w3/ Rhead ** 6.0d0)  &
24169        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24170
24171        ECL = c1 - c2 + c3
24172
24173        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
24174        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
24175        * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
24176        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
24177        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24178
24179        dGCLdR = c1 - c2 + c3
24180 !c! dECL/dom1
24181        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
24182        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24183        * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
24184        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
24185        dGCLdOM1 = c1 - c2 + c3
24186 !c! dECL/dom2
24187        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
24188        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24189        * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
24190        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
24191
24192        dGCLdOM2 = c1 - c2 + c3
24193 !c! dECL/dom12
24194        c1 = w1 / (Rhead ** 3.0d0)
24195        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
24196        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
24197        dGCLdOM12 = c1 - c2 + c3
24198        DO k= 1, 3
24199       erhead(k) = Rhead_distance(k)/Rhead
24200        END DO
24201        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24202        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24203 !       facd1 = d1 * vbld_inv(i+nres)
24204 !       facd2 = d2 * vbld_inv(j+nres)
24205        DO k = 1, 3
24206
24207 !        pom = erhead(k)
24208 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24209 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
24210 !                  - dGCLdR * pom
24211       pom = erhead(k)
24212 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24213       gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24214               + dGCLdR * pom
24215
24216       gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24217               - dGCLdR * erhead(k)/2.0d0
24218 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24219       gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24220               - dGCLdR * erhead(k)/2.0d0
24221 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24222       gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24223               + dGCLdR * erhead(k)
24224        END DO
24225 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
24226        epepbase=epepbase+evdwij+Fcav+ECL
24227        call sc_grad_pepbase
24228        enddo
24229        enddo
24230       END SUBROUTINE epep_sc_base
24231       SUBROUTINE sc_grad_pepbase
24232       use calc_data
24233
24234        real (kind=8) :: dcosom1(3),dcosom2(3)
24235        eom1  =    &
24236             eps2der * eps2rt_om1   &
24237           - 2.0D0 * alf1 * eps3der &
24238           + sigder * sigsq_om1     &
24239           + dCAVdOM1               &
24240           + dGCLdOM1               &
24241           + dPOLdOM1
24242
24243        eom2  =  &
24244             eps2der * eps2rt_om2   &
24245           + 2.0D0 * alf2 * eps3der &
24246           + sigder * sigsq_om2     &
24247           + dCAVdOM2               &
24248           + dGCLdOM2               &
24249           + dPOLdOM2
24250
24251        eom12 =    &
24252             evdwij  * eps1_om12     &
24253           + eps2der * eps2rt_om12   &
24254           - 2.0D0 * alf12 * eps3der &
24255           + sigder *sigsq_om12      &
24256           + dCAVdOM12               &
24257           + dGCLdOM12
24258 !        om12=0.0
24259 !        eom12=0.0
24260 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24261 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
24262 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24263 !                 *dsci_inv*2.0
24264 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24265 !               gg(1),gg(2),"rozne"
24266        DO k = 1, 3
24267       dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
24268       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24269       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24270       gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
24271              + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24272              *dsci_inv*2.0 &
24273              - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24274       gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
24275              - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
24276              *dsci_inv*2.0 &
24277              + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24278 !         print *,eom12,eom2,om12,om2
24279 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
24280 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
24281       gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
24282              + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
24283              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24284       gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
24285        END DO
24286        RETURN
24287       END SUBROUTINE sc_grad_pepbase
24288       subroutine eprot_sc_phosphate(escpho)
24289       use calc_data
24290 !      implicit real*8 (a-h,o-z)
24291 !      include 'DIMENSIONS'
24292 !      include 'COMMON.GEO'
24293 !      include 'COMMON.VAR'
24294 !      include 'COMMON.LOCAL'
24295 !      include 'COMMON.CHAIN'
24296 !      include 'COMMON.DERIV'
24297 !      include 'COMMON.NAMES'
24298 !      include 'COMMON.INTERACT'
24299 !      include 'COMMON.IOUNITS'
24300 !      include 'COMMON.CALC'
24301 !      include 'COMMON.CONTROL'
24302 !      include 'COMMON.SBRIDGE'
24303       logical :: lprn
24304 !el local variables
24305       integer :: iint,itypi,itypi1,itypj,subchap
24306       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24307       real(kind=8) :: evdw,sig0ij,aa,bb
24308       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24309                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
24310                 sslipi,sslipj,faclip,alpha_sco
24311       integer :: ii
24312       real(kind=8) :: fracinbuf
24313        real (kind=8) :: escpho
24314        real (kind=8),dimension(4):: ener
24315        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24316        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24317       sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
24318       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24319       dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
24320       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24321       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24322       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
24323        real(kind=8),dimension(3,2)::chead,erhead_tail
24324        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24325        integer troll
24326        eps_out=80.0d0
24327        escpho=0.0d0
24328 !       do i=1,nres_molec(1)
24329       do i=ibond_start,ibond_end
24330       if (itype(i,1).eq.ntyp1_molec(1)) cycle
24331       itypi  = itype(i,1)
24332       dxi    = dc_norm(1,nres+i)
24333       dyi    = dc_norm(2,nres+i)
24334       dzi    = dc_norm(3,nres+i)
24335       dsci_inv = vbld_inv(i+nres)
24336       xi=c(1,nres+i)
24337       yi=c(2,nres+i)
24338       zi=c(3,nres+i)
24339        call to_box(xi,yi,zi)
24340       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
24341        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
24342          itypj= itype(j,2)
24343          if ((itype(j,2).eq.ntyp1_molec(2)).or.&
24344           (itype(j+1,2).eq.ntyp1_molec(2))) cycle
24345          xj=(c(1,j)+c(1,j+1))/2.0
24346          yj=(c(2,j)+c(2,j+1))/2.0
24347          zj=(c(3,j)+c(3,j+1))/2.0
24348      call to_box(xj,yj,zj)
24349      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
24350       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
24351        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
24352       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
24353        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
24354       xj=boxshift(xj-xi,boxxsize)
24355       yj=boxshift(yj-yi,boxysize)
24356       zj=boxshift(zj-zi,boxzsize)
24357           dxj = dc_norm( 1,j )
24358         dyj = dc_norm( 2,j )
24359         dzj = dc_norm( 3,j )
24360         dscj_inv = vbld_inv(j+1)
24361
24362 ! Gay-berne var's
24363         sig0ij = sigma_scpho(itypi )
24364         chi1   = chi_scpho(itypi,1 )
24365         chi2   = chi_scpho(itypi,2 )
24366 !          chi1=0.0d0
24367 !          chi2=0.0d0
24368         chi12  = chi1 * chi2
24369         chip1  = chipp_scpho(itypi,1 )
24370         chip2  = chipp_scpho(itypi,2 )
24371 !          chip1=0.0d0
24372 !          chip2=0.0d0
24373         chip12 = chip1 * chip2
24374         chis1 = chis_scpho(itypi,1)
24375         chis2 = chis_scpho(itypi,2)
24376         chis12 = chis1 * chis2
24377         sig1 = sigmap1_scpho(itypi)
24378         sig2 = sigmap2_scpho(itypi)
24379 !       write (*,*) "sig1 = ", sig1
24380 !       write (*,*) "sig1 = ", sig1
24381 !       write (*,*) "sig2 = ", sig2
24382 ! alpha factors from Fcav/Gcav
24383         alf1   = 0.0d0
24384         alf2   = 0.0d0
24385         alf12  = 0.0d0
24386         a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
24387
24388         b1 = alphasur_scpho(1,itypi)
24389 !          b1=0.0d0
24390         b2 = alphasur_scpho(2,itypi)
24391         b3 = alphasur_scpho(3,itypi)
24392         b4 = alphasur_scpho(4,itypi)
24393 ! used to determine whether we want to do quadrupole calculations
24394 ! used by Fgb
24395        eps_in = epsintab_scpho(itypi)
24396        if (eps_in.eq.0.0) eps_in=1.0
24397        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
24398 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
24399 !-------------------------------------------------------------------
24400 ! tail location and distance calculations
24401         d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
24402         d1j = 0.0
24403        DO k = 1,3
24404 ! location of polar head is computed by taking hydrophobic centre
24405 ! and moving by a d1 * dc_norm vector
24406 ! see unres publications for very informative images
24407       chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
24408       chead(k,2) = (c(k, j) + c(k, j+1))/2.0
24409 ! distance
24410 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24411 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24412       Rhead_distance(k) = chead(k,2) - chead(k,1)
24413        END DO
24414 ! pitagoras (root of sum of squares)
24415        Rhead = dsqrt( &
24416         (Rhead_distance(1)*Rhead_distance(1)) &
24417       + (Rhead_distance(2)*Rhead_distance(2)) &
24418       + (Rhead_distance(3)*Rhead_distance(3)))
24419        Rhead_sq=Rhead**2.0
24420 !-------------------------------------------------------------------
24421 ! zero everything that should be zero'ed
24422        evdwij = 0.0d0
24423        ECL = 0.0d0
24424        Elj = 0.0d0
24425        Equad = 0.0d0
24426        Epol = 0.0d0
24427        Fcav=0.0d0
24428        eheadtail = 0.0d0
24429        dGCLdR=0.0d0
24430        dGCLdOM1 = 0.0d0
24431        dGCLdOM2 = 0.0d0
24432        dGCLdOM12 = 0.0d0
24433        dPOLdOM1 = 0.0d0
24434        dPOLdOM2 = 0.0d0
24435         Fcav = 0.0d0
24436         dFdR = 0.0d0
24437         dCAVdOM1  = 0.0d0
24438         dCAVdOM2  = 0.0d0
24439         dCAVdOM12 = 0.0d0
24440         dscj_inv = vbld_inv(j+1)/2.0
24441 !dhead_scbasej(itypi,itypj)
24442 !          print *,i,j,dscj_inv,dsci_inv
24443 ! rij holds 1/(distance of Calpha atoms)
24444         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24445         rij  = dsqrt(rrij)
24446 !----------------------------
24447         CALL sc_angular
24448 ! this should be in elgrad_init but om's are calculated by sc_angular
24449 ! which in turn is used by older potentials
24450 ! om = omega, sqom = om^2
24451         sqom1  = om1 * om1
24452         sqom2  = om2 * om2
24453         sqom12 = om12 * om12
24454
24455 ! now we calculate EGB - Gey-Berne
24456 ! It will be summed up in evdwij and saved in evdw
24457         sigsq     = 1.0D0  / sigsq
24458         sig       = sig0ij * dsqrt(sigsq)
24459 !          rij_shift = 1.0D0  / rij - sig + sig0ij
24460         rij_shift = 1.0/rij - sig + sig0ij
24461         IF (rij_shift.le.0.0D0) THEN
24462          evdw = 1.0D20
24463          RETURN
24464         END IF
24465         sigder = -sig * sigsq
24466         rij_shift = 1.0D0 / rij_shift
24467         fac       = rij_shift**expon
24468         c1        = fac  * fac * aa_scpho(itypi)
24469 !          c1        = 0.0d0
24470         c2        = fac  * bb_scpho(itypi)
24471 !          c2        = 0.0d0
24472         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24473         eps2der   = eps3rt * evdwij
24474         eps3der   = eps2rt * evdwij
24475 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24476         evdwij    = eps2rt * eps3rt * evdwij
24477         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24478         fac    = -expon * (c1 + evdwij) * rij_shift
24479         sigder = fac * sigder
24480 !          fac    = rij * fac
24481 ! Calculate distance derivative
24482         gg(1) =  fac
24483         gg(2) =  fac
24484         gg(3) =  fac
24485         fac = chis1 * sqom1 + chis2 * sqom2 &
24486         - 2.0d0 * chis12 * om1 * om2 * om12
24487 ! we will use pom later in Gcav, so dont mess with it!
24488         pom = 1.0d0 - chis1 * chis2 * sqom12
24489         Lambf = (1.0d0 - (fac / pom))
24490         Lambf = dsqrt(Lambf)
24491         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24492 !       write (*,*) "sparrow = ", sparrow
24493         Chif = 1.0d0/rij * sparrow
24494         ChiLambf = Chif * Lambf
24495         eagle = dsqrt(ChiLambf)
24496         bat = ChiLambf ** 11.0d0
24497         top = b1 * ( eagle + b2 * ChiLambf - b3 )
24498         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24499         botsq = bot * bot
24500         Fcav = top / bot
24501         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24502         dbot = 12.0d0 * b4 * bat * Lambf
24503         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24504 !       dFdR = 0.0d0
24505 !      write (*,*) "dFcav/dR = ", dFdR
24506         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24507         dbot = 12.0d0 * b4 * bat * Chif
24508         eagle = Lambf * pom
24509         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24510         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24511         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24512             * (chis2 * om2 * om12 - om1) / (eagle * pom)
24513
24514         dFdL = ((dtop * bot - top * dbot) / botsq)
24515 !       dFdL = 0.0d0
24516         dCAVdOM1  = dFdL * ( dFdOM1 )
24517         dCAVdOM2  = dFdL * ( dFdOM2 )
24518         dCAVdOM12 = dFdL * ( dFdOM12 )
24519
24520         ertail(1) = xj*rij
24521         ertail(2) = yj*rij
24522         ertail(3) = zj*rij
24523        DO k = 1, 3
24524 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24525 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24526 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
24527
24528       pom = ertail(k)
24529 !        print *,pom,gg(k),dFdR
24530 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24531       gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
24532               - (( dFdR + gg(k) ) * pom)
24533 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24534 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24535 !     &             - ( dFdR * pom )
24536 !        pom = ertail(k)
24537 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24538 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
24539 !                  + (( dFdR + gg(k) ) * pom)
24540 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24541 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24542 !c!     &             + ( dFdR * pom )
24543
24544       gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
24545               - (( dFdR + gg(k) ) * ertail(k))
24546 !c!     &             - ( dFdR * ertail(k))
24547
24548       gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
24549               + (( dFdR + gg(k) ) * ertail(k))/2.0
24550
24551       gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
24552               + (( dFdR + gg(k) ) * ertail(k))/2.0
24553
24554 !c!     &             + ( dFdR * ertail(k))
24555
24556       gg(k) = 0.0d0
24557       ENDDO
24558 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24559 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24560 !      alphapol1 = alphapol_scpho(itypi)
24561        if (wqq_scpho(itypi).ne.0.0) then
24562        Qij=wqq_scpho(itypi)/eps_in
24563        alpha_sco=1.d0/alphi_scpho(itypi)
24564 !       Qij=0.0
24565        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
24566 !c! derivative of Ecl is Gcl...
24567        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
24568             (Rhead*alpha_sco+1) ) / Rhead_sq
24569        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
24570        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
24571        w1        = wqdip_scpho(1,itypi)
24572        w2        = wqdip_scpho(2,itypi)
24573 !       w1=0.0d0
24574 !       w2=0.0d0
24575 !       pis       = sig0head_scbase(itypi,itypj)
24576 !       eps_head   = epshead_scbase(itypi,itypj)
24577 !c!-------------------------------------------------------------------
24578
24579 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24580 !c!     &        +dhead(1,1,itypi,itypj))**2))
24581 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24582 !c!     &        +dhead(2,1,itypi,itypj))**2))
24583
24584 !c!-------------------------------------------------------------------
24585 !c! ecl
24586        sparrow  = w1  *  om1
24587        hawk     = w2 *  (1.0d0 - sqom2)
24588        Ecl = sparrow / Rhead**2.0d0 &
24589          - hawk    / Rhead**4.0d0
24590 !c!-------------------------------------------------------------------
24591        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
24592          1.0/rij,sparrow
24593
24594 !c! derivative of ecl is Gcl
24595 !c! dF/dr part
24596        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
24597             + 4.0d0 * hawk    / Rhead**5.0d0
24598 !c! dF/dom1
24599        dGCLdOM1 = (w1) / (Rhead**2.0d0)
24600 !c! dF/dom2
24601        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
24602        endif
24603
24604 !c--------------------------------------------------------------------
24605 !c Polarization energy
24606 !c Epol
24607        R1 = 0.0d0
24608        DO k = 1, 3
24609 !c! Calculate head-to-tail distances tail is center of side-chain
24610       R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
24611        END DO
24612 !c! Pitagoras
24613        R1 = dsqrt(R1)
24614
24615       alphapol1 = alphapol_scpho(itypi)
24616 !      alphapol1=0.0
24617        MomoFac1 = (1.0d0 - chi2 * sqom1)
24618        RR1  = R1 * R1 / MomoFac1
24619        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24620 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
24621        fgb1 = sqrt( RR1 + a12sq * ee1)
24622 !       eps_inout_fac=0.0d0
24623        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
24624 ! derivative of Epol is Gpol...
24625        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
24626             / (fgb1 ** 5.0d0)
24627        dFGBdR1 = ( (R1 / MomoFac1) &
24628            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
24629            / ( 2.0d0 * fgb1 )
24630        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
24631              * (2.0d0 - 0.5d0 * ee1) ) &
24632              / (2.0d0 * fgb1)
24633        dPOLdR1 = dPOLdFGB1 * dFGBdR1
24634 !       dPOLdR1 = 0.0d0
24635 !       dPOLdOM1 = 0.0d0
24636        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
24637              * (2.0d0 - 0.5d0 * ee1) ) &
24638              / (2.0d0 * fgb1)
24639
24640        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
24641        dPOLdOM2 = 0.0
24642        DO k = 1, 3
24643       erhead(k) = Rhead_distance(k)/Rhead
24644       erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
24645        END DO
24646
24647        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24648        erdxj = scalar( erhead(1), dC_norm(1,j) )
24649        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
24650 !       bat=0.0d0
24651        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
24652        facd1 = d1i * vbld_inv(i+nres)
24653        facd2 = d1j * vbld_inv(j)
24654 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24655
24656        DO k = 1, 3
24657       hawk = (erhead_tail(k,1) + &
24658       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
24659 !        facd1=0.0d0
24660 !        facd2=0.0d0
24661 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
24662 !                pom,(erhead_tail(k,1))
24663
24664 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
24665       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24666       gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
24667                - dGCLdR * pom &
24668                - dPOLdR1 *  (erhead_tail(k,1))
24669 !     &             - dGLJdR * pom
24670
24671       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
24672 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
24673 !                   + dGCLdR * pom  &
24674 !                   + dPOLdR1 * (erhead_tail(k,1))
24675 !     &             + dGLJdR * pom
24676
24677
24678       gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
24679               - dGCLdR * erhead(k) &
24680               - dPOLdR1 * erhead_tail(k,1)
24681 !     &             - dGLJdR * erhead(k)
24682
24683       gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
24684               + (dGCLdR * erhead(k)  &
24685               + dPOLdR1 * erhead_tail(k,1))/2.0
24686       gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
24687               + (dGCLdR * erhead(k)  &
24688               + dPOLdR1 * erhead_tail(k,1))/2.0
24689
24690 !     &             + dGLJdR * erhead(k)
24691 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
24692
24693        END DO
24694 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
24695        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
24696       "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
24697        escpho=escpho+evdwij+epol+Fcav+ECL
24698        call sc_grad_scpho
24699        enddo
24700
24701       enddo
24702
24703       return
24704       end subroutine eprot_sc_phosphate
24705       SUBROUTINE sc_grad_scpho
24706       use calc_data
24707
24708        real (kind=8) :: dcosom1(3),dcosom2(3)
24709        eom1  =    &
24710             eps2der * eps2rt_om1   &
24711           - 2.0D0 * alf1 * eps3der &
24712           + sigder * sigsq_om1     &
24713           + dCAVdOM1               &
24714           + dGCLdOM1               &
24715           + dPOLdOM1
24716
24717        eom2  =  &
24718             eps2der * eps2rt_om2   &
24719           + 2.0D0 * alf2 * eps3der &
24720           + sigder * sigsq_om2     &
24721           + dCAVdOM2               &
24722           + dGCLdOM2               &
24723           + dPOLdOM2
24724
24725        eom12 =    &
24726             evdwij  * eps1_om12     &
24727           + eps2der * eps2rt_om12   &
24728           - 2.0D0 * alf12 * eps3der &
24729           + sigder *sigsq_om12      &
24730           + dCAVdOM12               &
24731           + dGCLdOM12
24732 !        om12=0.0
24733 !        eom12=0.0
24734 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24735 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
24736 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24737 !                 *dsci_inv*2.0
24738 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24739 !               gg(1),gg(2),"rozne"
24740        DO k = 1, 3
24741       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
24742       dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
24743       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24744       gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
24745              + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
24746              *dscj_inv*2.0 &
24747              - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24748       gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
24749              - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
24750              *dscj_inv*2.0 &
24751              + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24752       gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
24753              + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
24754              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24755
24756 !         print *,eom12,eom2,om12,om2
24757 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
24758 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
24759 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
24760 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
24761 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24762       gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
24763        END DO
24764        RETURN
24765       END SUBROUTINE sc_grad_scpho
24766       subroutine eprot_pep_phosphate(epeppho)
24767       use calc_data
24768 !      implicit real*8 (a-h,o-z)
24769 !      include 'DIMENSIONS'
24770 !      include 'COMMON.GEO'
24771 !      include 'COMMON.VAR'
24772 !      include 'COMMON.LOCAL'
24773 !      include 'COMMON.CHAIN'
24774 !      include 'COMMON.DERIV'
24775 !      include 'COMMON.NAMES'
24776 !      include 'COMMON.INTERACT'
24777 !      include 'COMMON.IOUNITS'
24778 !      include 'COMMON.CALC'
24779 !      include 'COMMON.CONTROL'
24780 !      include 'COMMON.SBRIDGE'
24781       logical :: lprn
24782 !el local variables
24783       integer :: iint,itypi,itypi1,itypj,subchap
24784       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24785       real(kind=8) :: evdw,sig0ij
24786       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24787                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24788                 sslipi,sslipj,faclip
24789       integer :: ii
24790       real(kind=8) :: fracinbuf
24791        real (kind=8) :: epeppho
24792        real (kind=8),dimension(4):: ener
24793        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24794        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24795       sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
24796       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24797       dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
24798       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24799       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24800       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
24801        real(kind=8),dimension(3,2)::chead,erhead_tail
24802        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24803        integer troll
24804        real (kind=8) :: dcosom1(3),dcosom2(3)
24805        epeppho=0.0d0
24806 !       do i=1,nres_molec(1)
24807       do i=ibond_start,ibond_end
24808       if (itype(i,1).eq.ntyp1_molec(1)) cycle
24809       itypi  = itype(i,1)
24810       dsci_inv = vbld_inv(i+1)/2.0
24811       dxi    = dc_norm(1,i)
24812       dyi    = dc_norm(2,i)
24813       dzi    = dc_norm(3,i)
24814       xi=(c(1,i)+c(1,i+1))/2.0
24815       yi=(c(2,i)+c(2,i+1))/2.0
24816       zi=(c(3,i)+c(3,i+1))/2.0
24817                call to_box(xi,yi,zi)
24818
24819         do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
24820          itypj= itype(j,2)
24821          if ((itype(j,2).eq.ntyp1_molec(2)).or.&
24822           (itype(j+1,2).eq.ntyp1_molec(2))) cycle
24823          xj=(c(1,j)+c(1,j+1))/2.0
24824          yj=(c(2,j)+c(2,j+1))/2.0
24825          zj=(c(3,j)+c(3,j+1))/2.0
24826                 call to_box(xj,yj,zj)
24827       xj=boxshift(xj-xi,boxxsize)
24828       yj=boxshift(yj-yi,boxysize)
24829       zj=boxshift(zj-zi,boxzsize)
24830
24831         dist_init=xj**2+yj**2+zj**2
24832         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24833         rij  = dsqrt(rrij)
24834         dxj = dc_norm( 1,j )
24835         dyj = dc_norm( 2,j )
24836         dzj = dc_norm( 3,j )
24837         dscj_inv = vbld_inv(j+1)/2.0
24838 ! Gay-berne var's
24839         sig0ij = sigma_peppho
24840 !          chi1=0.0d0
24841 !          chi2=0.0d0
24842         chi12  = chi1 * chi2
24843 !          chip1=0.0d0
24844 !          chip2=0.0d0
24845         chip12 = chip1 * chip2
24846 !          chis1 = 0.0d0
24847 !          chis2 = 0.0d0
24848         chis12 = chis1 * chis2
24849         sig1 = sigmap1_peppho
24850         sig2 = sigmap2_peppho
24851 !       write (*,*) "sig1 = ", sig1
24852 !       write (*,*) "sig1 = ", sig1
24853 !       write (*,*) "sig2 = ", sig2
24854 ! alpha factors from Fcav/Gcav
24855         alf1   = 0.0d0
24856         alf2   = 0.0d0
24857         alf12  = 0.0d0
24858         b1 = alphasur_peppho(1)
24859 !          b1=0.0d0
24860         b2 = alphasur_peppho(2)
24861         b3 = alphasur_peppho(3)
24862         b4 = alphasur_peppho(4)
24863         CALL sc_angular
24864        sqom1=om1*om1
24865        evdwij = 0.0d0
24866        ECL = 0.0d0
24867        Elj = 0.0d0
24868        Equad = 0.0d0
24869        Epol = 0.0d0
24870        Fcav=0.0d0
24871        eheadtail = 0.0d0
24872        dGCLdR=0.0d0
24873        dGCLdOM1 = 0.0d0
24874        dGCLdOM2 = 0.0d0
24875        dGCLdOM12 = 0.0d0
24876        dPOLdOM1 = 0.0d0
24877        dPOLdOM2 = 0.0d0
24878         Fcav = 0.0d0
24879         dFdR = 0.0d0
24880         dCAVdOM1  = 0.0d0
24881         dCAVdOM2  = 0.0d0
24882         dCAVdOM12 = 0.0d0
24883         rij_shift = rij
24884         fac       = rij_shift**expon
24885         c1        = fac  * fac * aa_peppho
24886 !          c1        = 0.0d0
24887         c2        = fac  * bb_peppho
24888 !          c2        = 0.0d0
24889         evdwij    =  c1 + c2
24890 ! Now cavity....................
24891        eagle = dsqrt(1.0/rij_shift)
24892        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
24893         bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
24894         botsq = bot * bot
24895         Fcav = top / bot
24896         dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
24897         dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
24898         dFdR = ((dtop * bot - top * dbot) / botsq)
24899        w1        = wqdip_peppho(1)
24900        w2        = wqdip_peppho(2)
24901 !       w1=0.0d0
24902 !       w2=0.0d0
24903 !       pis       = sig0head_scbase(itypi,itypj)
24904 !       eps_head   = epshead_scbase(itypi,itypj)
24905 !c!-------------------------------------------------------------------
24906
24907 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24908 !c!     &        +dhead(1,1,itypi,itypj))**2))
24909 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24910 !c!     &        +dhead(2,1,itypi,itypj))**2))
24911
24912 !c!-------------------------------------------------------------------
24913 !c! ecl
24914        sparrow  = w1  *  om1
24915        hawk     = w2 *  (1.0d0 - sqom1)
24916        Ecl = sparrow * rij_shift**2.0d0 &
24917          - hawk    * rij_shift**4.0d0
24918 !c!-------------------------------------------------------------------
24919 !c! derivative of ecl is Gcl
24920 !c! dF/dr part
24921 !       rij_shift=5.0
24922        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
24923             + 4.0d0 * hawk    * rij_shift**5.0d0
24924 !c! dF/dom1
24925        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
24926 !c! dF/dom2
24927        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
24928        eom1  =    dGCLdOM1+dGCLdOM2
24929        eom2  =    0.0
24930
24931         fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
24932 !          fac=0.0
24933         gg(1) =  fac*xj*rij
24934         gg(2) =  fac*yj*rij
24935         gg(3) =  fac*zj*rij
24936        do k=1,3
24937        gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
24938        gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
24939        gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
24940        gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
24941        gg(k)=0.0
24942        enddo
24943
24944       DO k = 1, 3
24945       dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
24946       dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
24947       gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
24948       gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
24949 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24950       gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
24951 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24952       gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
24953              - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24954       gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
24955              + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24956       enddo
24957        epeppho=epeppho+evdwij+Fcav+ECL
24958 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
24959        enddo
24960        enddo
24961       end subroutine eprot_pep_phosphate
24962 !!!!!!!!!!!!!!!!-------------------------------------------------------------
24963       subroutine emomo(evdw)
24964       use calc_data
24965       use comm_momo
24966 !      implicit real*8 (a-h,o-z)
24967 !      include 'DIMENSIONS'
24968 !      include 'COMMON.GEO'
24969 !      include 'COMMON.VAR'
24970 !      include 'COMMON.LOCAL'
24971 !      include 'COMMON.CHAIN'
24972 !      include 'COMMON.DERIV'
24973 !      include 'COMMON.NAMES'
24974 !      include 'COMMON.INTERACT'
24975 !      include 'COMMON.IOUNITS'
24976 !      include 'COMMON.CALC'
24977 !      include 'COMMON.CONTROL'
24978 !      include 'COMMON.SBRIDGE'
24979       logical :: lprn
24980 !el local variables
24981       integer :: iint,itypi1,subchap,isel
24982       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
24983       real(kind=8) :: evdw,aa,bb
24984       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24985                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
24986                 sslipi,sslipj,faclip,alpha_sco
24987       integer :: ii
24988       real(kind=8) :: fracinbuf
24989        real (kind=8) :: escpho
24990        real (kind=8),dimension(4):: ener
24991        real(kind=8) :: b1,b2,egb
24992        real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
24993       Lambf,&
24994       Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
24995       dFdOM2,dFdL,dFdOM12,&
24996       federmaus,&
24997       d1i,d1j
24998 !       real(kind=8),dimension(3,2)::erhead_tail
24999 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
25000        real(kind=8) ::  facd4, adler, Fgb, facd3
25001        integer troll,jj,istate
25002        real (kind=8) :: dcosom1(3),dcosom2(3)
25003        evdw=0.0d0
25004        eps_out=80.0d0
25005        sss_ele_cut=1.0d0
25006 !       print *,"EVDW KURW",evdw,nres
25007       do i=iatsc_s,iatsc_e
25008 !        print *,"I am in EVDW",i
25009       itypi=iabs(itype(i,1))
25010 !        if (i.ne.47) cycle
25011       if (itypi.eq.ntyp1) cycle
25012       itypi1=iabs(itype(i+1,1))
25013       xi=c(1,nres+i)
25014       yi=c(2,nres+i)
25015       zi=c(3,nres+i)
25016         call to_box(xi,yi,zi)
25017         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
25018        if ((zi.gt.bordlipbot)  &
25019       .and.(zi.lt.bordliptop)) then
25020 !C the energy transfer exist
25021       if (zi.lt.buflipbot) then
25022 !C what fraction I am in
25023        fracinbuf=1.0d0-  &
25024             ((zi-bordlipbot)/lipbufthick)
25025 !C lipbufthick is thickenes of lipid buffore
25026        sslipi=sscalelip(fracinbuf)
25027        ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
25028       elseif (zi.gt.bufliptop) then
25029        fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
25030        sslipi=sscalelip(fracinbuf)
25031        ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
25032       else
25033        sslipi=1.0d0
25034        ssgradlipi=0.0
25035       endif
25036        else
25037        sslipi=0.0d0
25038        ssgradlipi=0.0
25039        endif
25040 !       print *, sslipi,ssgradlipi
25041       dxi=dc_norm(1,nres+i)
25042       dyi=dc_norm(2,nres+i)
25043       dzi=dc_norm(3,nres+i)
25044 !        dsci_inv=dsc_inv(itypi)
25045       dsci_inv=vbld_inv(i+nres)
25046 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
25047 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
25048 !
25049 ! Calculate SC interaction energy.
25050 !
25051       do iint=1,nint_gr(i)
25052         do j=istart(i,iint),iend(i,iint)
25053 !             print *,"JA PIER",i,j,iint,istart(i,iint),iend(i,iint)
25054           IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
25055             call dyn_ssbond_ene(i,j,evdwij)
25056             evdw=evdw+evdwij
25057             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25058                         'evdw',i,j,evdwij,' ss'
25059 !              if (energy_dec) write (iout,*) &
25060 !                              'evdw',i,j,evdwij,' ss'
25061            do k=j+1,iend(i,iint)
25062 !C search over all next residues
25063             if (dyn_ss_mask(k)) then
25064 !C check if they are cysteins
25065 !C              write(iout,*) 'k=',k
25066
25067 !c              write(iout,*) "PRZED TRI", evdwij
25068 !               evdwij_przed_tri=evdwij
25069             call triple_ssbond_ene(i,j,k,evdwij)
25070 !c               if(evdwij_przed_tri.ne.evdwij) then
25071 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
25072 !c               endif
25073
25074 !c              write(iout,*) "PO TRI", evdwij
25075 !C call the energy function that removes the artifical triple disulfide
25076 !C bond the soubroutine is located in ssMD.F
25077             evdw=evdw+evdwij
25078             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25079                       'evdw',i,j,evdwij,'tss'
25080             endif!dyn_ss_mask(k)
25081            enddo! k
25082           ELSE
25083 !el            ind=ind+1
25084           itypj=iabs(itype(j,1))
25085           if (itypj.eq.ntyp1) cycle
25086            CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
25087
25088 !             if (j.ne.78) cycle
25089 !            dscj_inv=dsc_inv(itypj)
25090           dscj_inv=vbld_inv(j+nres)
25091          xj=c(1,j+nres)
25092          yj=c(2,j+nres)
25093          zj=c(3,j+nres)
25094      call to_box(xj,yj,zj)
25095      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
25096       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
25097       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
25098       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
25099       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
25100       xj=boxshift(xj-xi,boxxsize)
25101       yj=boxshift(yj-yi,boxysize)
25102       zj=boxshift(zj-zi,boxzsize)
25103         dxj = dc_norm( 1, nres+j )
25104         dyj = dc_norm( 2, nres+j )
25105         dzj = dc_norm( 3, nres+j )
25106 !          print *,i,j,itypi,itypj
25107 !          d1i=0.0d0
25108 !          d1j=0.0d0
25109 !          BetaT = 1.0d0 / (298.0d0 * Rb)
25110 ! Gay-berne var's
25111 !1!          sig0ij = sigma_scsc( itypi,itypj )
25112 !          chi1=0.0d0
25113 !          chi2=0.0d0
25114 !          chip1=0.0d0
25115 !          chip2=0.0d0
25116 ! not used by momo potential, but needed by sc_angular which is shared
25117 ! by all energy_potential subroutines
25118         alf1   = 0.0d0
25119         alf2   = 0.0d0
25120         alf12  = 0.0d0
25121         a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
25122 !       a12sq = a12sq * a12sq
25123 ! charge of amino acid itypi is...
25124         chis1 = chis(itypi,itypj)
25125         chis2 = chis(itypj,itypi)
25126         chis12 = chis1 * chis2
25127         sig1 = sigmap1(itypi,itypj)
25128         sig2 = sigmap2(itypi,itypj)
25129 !       write (*,*) "sig1 = ", sig1
25130 !          chis1=0.0
25131 !          chis2=0.0
25132 !                    chis12 = chis1 * chis2
25133 !          sig1=0.0
25134 !          sig2=0.0
25135 !       write (*,*) "sig2 = ", sig2
25136 ! alpha factors from Fcav/Gcav
25137         b1cav = alphasur(1,itypi,itypj)
25138 !          b1cav=0.0d0
25139         b2cav = alphasur(2,itypi,itypj)
25140         b3cav = alphasur(3,itypi,itypj)
25141         b4cav = alphasur(4,itypi,itypj)
25142 ! used to determine whether we want to do quadrupole calculations
25143        eps_in = epsintab(itypi,itypj)
25144        if (eps_in.eq.0.0) eps_in=1.0
25145
25146        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
25147        Rtail = 0.0d0
25148 !       dtail(1,itypi,itypj)=0.0
25149 !       dtail(2,itypi,itypj)=0.0
25150
25151        DO k = 1, 3
25152       ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
25153       ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
25154        END DO
25155 !c! tail distances will be themselves usefull elswhere
25156 !c1 (in Gcav, for example)
25157        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
25158        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
25159        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
25160        Rtail = dsqrt( &
25161         (Rtail_distance(1)*Rtail_distance(1)) &
25162       + (Rtail_distance(2)*Rtail_distance(2)) &
25163       + (Rtail_distance(3)*Rtail_distance(3)))
25164
25165 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
25166 !-------------------------------------------------------------------
25167 ! tail location and distance calculations
25168        d1 = dhead(1, 1, itypi, itypj)
25169        d2 = dhead(2, 1, itypi, itypj)
25170
25171        DO k = 1,3
25172 ! location of polar head is computed by taking hydrophobic centre
25173 ! and moving by a d1 * dc_norm vector
25174 ! see unres publications for very informative images
25175       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
25176       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
25177 ! distance
25178 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25179 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25180       Rhead_distance(k) = chead(k,2) - chead(k,1)
25181        END DO
25182 ! pitagoras (root of sum of squares)
25183        Rhead = dsqrt( &
25184         (Rhead_distance(1)*Rhead_distance(1)) &
25185       + (Rhead_distance(2)*Rhead_distance(2)) &
25186       + (Rhead_distance(3)*Rhead_distance(3)))
25187 !-------------------------------------------------------------------
25188 ! zero everything that should be zero'ed
25189        evdwij = 0.0d0
25190        ECL = 0.0d0
25191        Elj = 0.0d0
25192        Equad = 0.0d0
25193        Epol = 0.0d0
25194        Fcav=0.0d0
25195        eheadtail = 0.0d0
25196        dGCLdOM1 = 0.0d0
25197        dGCLdOM2 = 0.0d0
25198        dGCLdOM12 = 0.0d0
25199        dPOLdOM1 = 0.0d0
25200        dPOLdOM2 = 0.0d0
25201         Fcav = 0.0d0
25202         dFdR = 0.0d0
25203         dCAVdOM1  = 0.0d0
25204         dCAVdOM2  = 0.0d0
25205         dCAVdOM12 = 0.0d0
25206         dscj_inv = vbld_inv(j+nres)
25207 !          print *,i,j,dscj_inv,dsci_inv
25208 ! rij holds 1/(distance of Calpha atoms)
25209         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25210         rij  = dsqrt(rrij)
25211 !----------------------------
25212         CALL sc_angular
25213 ! this should be in elgrad_init but om's are calculated by sc_angular
25214 ! which in turn is used by older potentials
25215 ! om = omega, sqom = om^2
25216         sqom1  = om1 * om1
25217         sqom2  = om2 * om2
25218         sqom12 = om12 * om12
25219
25220 ! now we calculate EGB - Gey-Berne
25221 ! It will be summed up in evdwij and saved in evdw
25222         sigsq     = 1.0D0  / sigsq
25223         sig       = sig0ij * dsqrt(sigsq)
25224 !          rij_shift = 1.0D0  / rij - sig + sig0ij
25225         rij_shift = Rtail - sig + sig0ij
25226         IF (rij_shift.le.0.0D0) THEN
25227          evdw = 1.0D20
25228          RETURN
25229         END IF
25230         sigder = -sig * sigsq
25231         rij_shift = 1.0D0 / rij_shift
25232         fac       = rij_shift**expon
25233         c1        = fac  * fac * aa_aq(itypi,itypj)
25234 !          print *,"ADAM",aa_aq(itypi,itypj)
25235
25236 !          c1        = 0.0d0
25237         c2        = fac  * bb_aq(itypi,itypj)
25238 !          c2        = 0.0d0
25239         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
25240         eps2der   = eps3rt * evdwij
25241         eps3der   = eps2rt * evdwij
25242 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
25243         evdwij    = eps2rt * eps3rt * evdwij
25244 !#ifdef TSCSC
25245 !          IF (bb_aq(itypi,itypj).gt.0) THEN
25246 !           evdw_p = evdw_p + evdwij
25247 !          ELSE
25248 !           evdw_m = evdw_m + evdwij
25249 !          END IF
25250 !#else
25251         evdw = evdw  &
25252             + evdwij
25253 !#endif
25254
25255         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
25256         fac    = -expon * (c1 + evdwij) * rij_shift
25257         sigder = fac * sigder
25258 !          fac    = rij * fac
25259 ! Calculate distance derivative
25260         gg(1) =  fac
25261         gg(2) =  fac
25262         gg(3) =  fac
25263 !          if (b2.gt.0.0) then
25264         fac = chis1 * sqom1 + chis2 * sqom2 &
25265         - 2.0d0 * chis12 * om1 * om2 * om12
25266 ! we will use pom later in Gcav, so dont mess with it!
25267         pom = 1.0d0 - chis1 * chis2 * sqom12
25268         Lambf = (1.0d0 - (fac / pom))
25269 !          print *,"fac,pom",fac,pom,Lambf
25270         Lambf = dsqrt(Lambf)
25271         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
25272 !          print *,"sig1,sig2",sig1,sig2,itypi,itypj
25273 !       write (*,*) "sparrow = ", sparrow
25274         Chif = Rtail * sparrow
25275 !           print *,"rij,sparrow",rij , sparrow
25276         ChiLambf = Chif * Lambf
25277         eagle = dsqrt(ChiLambf)
25278         bat = ChiLambf ** 11.0d0
25279         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
25280         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
25281         botsq = bot * bot
25282 !          print *,top,bot,"bot,top",ChiLambf,Chif
25283         Fcav = top / bot
25284
25285        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
25286        dbot = 12.0d0 * b4cav * bat * Lambf
25287        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25288
25289         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
25290         dbot = 12.0d0 * b4cav * bat * Chif
25291         eagle = Lambf * pom
25292         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25293         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25294         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25295             * (chis2 * om2 * om12 - om1) / (eagle * pom)
25296
25297         dFdL = ((dtop * bot - top * dbot) / botsq)
25298 !       dFdL = 0.0d0
25299         dCAVdOM1  = dFdL * ( dFdOM1 )
25300         dCAVdOM2  = dFdL * ( dFdOM2 )
25301         dCAVdOM12 = dFdL * ( dFdOM12 )
25302
25303        DO k= 1, 3
25304       ertail(k) = Rtail_distance(k)/Rtail
25305        END DO
25306        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
25307        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
25308        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25309        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25310        DO k = 1, 3
25311 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25312 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25313       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25314       gvdwx(k,i) = gvdwx(k,i) &
25315               - (( dFdR + gg(k) ) * pom)
25316 !c!     &             - ( dFdR * pom )
25317       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25318       gvdwx(k,j) = gvdwx(k,j)   &
25319               + (( dFdR + gg(k) ) * pom)
25320 !c!     &             + ( dFdR * pom )
25321
25322       gvdwc(k,i) = gvdwc(k,i)  &
25323               - (( dFdR + gg(k) ) * ertail(k))
25324 !c!     &             - ( dFdR * ertail(k))
25325
25326       gvdwc(k,j) = gvdwc(k,j) &
25327               + (( dFdR + gg(k) ) * ertail(k))
25328 !c!     &             + ( dFdR * ertail(k))
25329
25330       gg(k) = 0.0d0
25331 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25332 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25333       END DO
25334
25335
25336 !c! Compute head-head and head-tail energies for each state
25337
25338         isel = iabs(Qi) + iabs(Qj)
25339 ! double charge for Phophorylated! itype - 25,27,27
25340 !          if ((itype(i).eq.27).or.(itype(i).eq.26).or.(itype(i).eq.25)) then
25341 !            Qi=Qi*2
25342 !            Qij=Qij*2
25343 !           endif
25344 !          if ((itype(j).eq.27).or.(itype(j).eq.26).or.(itype(j).eq.25)) then
25345 !            Qj=Qj*2
25346 !            Qij=Qij*2
25347 !           endif
25348
25349 !          isel=0
25350         IF (isel.eq.0) THEN
25351 !c! No charges - do nothing
25352          eheadtail = 0.0d0
25353
25354         ELSE IF (isel.eq.4) THEN
25355 !c! Calculate dipole-dipole interactions
25356          CALL edd(ecl)
25357          eheadtail = ECL
25358 !           eheadtail = 0.0d0
25359
25360         ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
25361 !c! Charge-nonpolar interactions
25362         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25363           Qi=Qi*2
25364           Qij=Qij*2
25365          endif
25366         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25367           Qj=Qj*2
25368           Qij=Qij*2
25369          endif
25370
25371          CALL eqn(epol)
25372          eheadtail = epol
25373 !           eheadtail = 0.0d0
25374
25375         ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
25376 !c! Nonpolar-charge interactions
25377         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25378           Qi=Qi*2
25379           Qij=Qij*2
25380          endif
25381         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25382           Qj=Qj*2
25383           Qij=Qij*2
25384          endif
25385
25386          CALL enq(epol)
25387          eheadtail = epol
25388 !           eheadtail = 0.0d0
25389
25390         ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
25391 !c! Charge-dipole interactions
25392         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25393           Qi=Qi*2
25394           Qij=Qij*2
25395          endif
25396         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25397           Qj=Qj*2
25398           Qij=Qij*2
25399          endif
25400
25401          CALL eqd(ecl, elj, epol)
25402          eheadtail = ECL + elj + epol
25403 !           eheadtail = 0.0d0
25404
25405         ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
25406 !c! Dipole-charge interactions
25407         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25408           Qi=Qi*2
25409           Qij=Qij*2
25410          endif
25411         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25412           Qj=Qj*2
25413           Qij=Qij*2
25414          endif
25415          CALL edq(ecl, elj, epol)
25416         eheadtail = ECL + elj + epol
25417 !           eheadtail = 0.0d0
25418
25419         ELSE IF ((isel.eq.2.and.   &
25420              iabs(Qi).eq.1).and.  &
25421              nstate(itypi,itypj).eq.1) THEN
25422 !c! Same charge-charge interaction ( +/+ or -/- )
25423         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25424           Qi=Qi*2
25425           Qij=Qij*2
25426          endif
25427         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25428           Qj=Qj*2
25429           Qij=Qij*2
25430          endif
25431
25432          CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
25433          eheadtail = ECL + Egb + Epol + Fisocav + Elj
25434 !           eheadtail = 0.0d0
25435
25436         ELSE IF ((isel.eq.2.and.  &
25437              iabs(Qi).eq.1).and. &
25438              nstate(itypi,itypj).ne.1) THEN
25439 !c! Different charge-charge interaction ( +/- or -/+ )
25440         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25441           Qi=Qi*2
25442           Qij=Qij*2
25443          endif
25444         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25445           Qj=Qj*2
25446           Qij=Qij*2
25447          endif
25448
25449          CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
25450         END IF
25451        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
25452       evdw = evdw  + Fcav + eheadtail
25453
25454        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
25455       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
25456       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
25457       Equad,evdwij+Fcav+eheadtail,evdw
25458 !       evdw = evdw  + Fcav  + eheadtail
25459
25460       iF (nstate(itypi,itypj).eq.1) THEN
25461       CALL sc_grad
25462        END IF
25463 !c!-------------------------------------------------------------------
25464 !c! NAPISY KONCOWE
25465        END DO   ! j
25466       END DO    ! iint
25467        END DO     ! i
25468 !c      write (iout,*) "Number of loop steps in EGB:",ind
25469 !c      energy_dec=.false.
25470 !              print *,"EVDW KURW",evdw,nres
25471
25472        RETURN
25473       END SUBROUTINE emomo
25474 !C------------------------------------------------------------------------------------
25475       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
25476       use calc_data
25477       use comm_momo
25478        real (kind=8) ::  facd3, facd4, federmaus, adler,&
25479        Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
25480 !       integer :: k
25481 !c! Epol and Gpol analytical parameters
25482        alphapol1 = alphapol(itypi,itypj)
25483        alphapol2 = alphapol(itypj,itypi)
25484 !c! Fisocav and Gisocav analytical parameters
25485        al1  = alphiso(1,itypi,itypj)
25486        al2  = alphiso(2,itypi,itypj)
25487        al3  = alphiso(3,itypi,itypj)
25488        al4  = alphiso(4,itypi,itypj)
25489        csig = (1.0d0  &
25490          / dsqrt(sigiso1(itypi, itypj)**2.0d0 &
25491          + sigiso2(itypi,itypj)**2.0d0))
25492 !c!
25493        pis  = sig0head(itypi,itypj)
25494        eps_head = epshead(itypi,itypj)
25495        Rhead_sq = Rhead * Rhead
25496 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25497 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25498        R1 = 0.0d0
25499        R2 = 0.0d0
25500        DO k = 1, 3
25501 !c! Calculate head-to-tail distances needed by Epol
25502       R1=R1+(ctail(k,2)-chead(k,1))**2
25503       R2=R2+(chead(k,2)-ctail(k,1))**2
25504        END DO
25505 !c! Pitagoras
25506        R1 = dsqrt(R1)
25507        R2 = dsqrt(R2)
25508
25509 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25510 !c!     &        +dhead(1,1,itypi,itypj))**2))
25511 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25512 !c!     &        +dhead(2,1,itypi,itypj))**2))
25513
25514 !c!-------------------------------------------------------------------
25515 !c! Coulomb electrostatic interaction
25516        Ecl = (332.0d0 * Qij) / Rhead
25517 !c! derivative of Ecl is Gcl...
25518        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
25519        dGCLdOM1 = 0.0d0
25520        dGCLdOM2 = 0.0d0
25521        dGCLdOM12 = 0.0d0
25522        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
25523        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
25524        debkap=debaykap(itypi,itypj)
25525        Egb = -(332.0d0 * Qij *&
25526       (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
25527 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
25528 !c! Derivative of Egb is Ggb...
25529        dGGBdFGB = -(-332.0d0 * Qij * &
25530        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
25531        -(332.0d0 * Qij *&
25532       (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
25533        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
25534        dGGBdR = dGGBdFGB * dFGBdR
25535 !c!-------------------------------------------------------------------
25536 !c! Fisocav - isotropic cavity creation term
25537 !c! or "how much energy it costs to put charged head in water"
25538        pom = Rhead * csig
25539        top = al1 * (dsqrt(pom) + al2 * pom - al3)
25540        bot = (1.0d0 + al4 * pom**12.0d0)
25541        botsq = bot * bot
25542        FisoCav = top / bot
25543 !      write (*,*) "Rhead = ",Rhead
25544 !      write (*,*) "csig = ",csig
25545 !      write (*,*) "pom = ",pom
25546 !      write (*,*) "al1 = ",al1
25547 !      write (*,*) "al2 = ",al2
25548 !      write (*,*) "al3 = ",al3
25549 !      write (*,*) "al4 = ",al4
25550 !        write (*,*) "top = ",top
25551 !        write (*,*) "bot = ",bot
25552 !c! Derivative of Fisocav is GCV...
25553        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
25554        dbot = 12.0d0 * al4 * pom ** 11.0d0
25555        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
25556 !c!-------------------------------------------------------------------
25557 !c! Epol
25558 !c! Polarization energy - charged heads polarize hydrophobic "neck"
25559        MomoFac1 = (1.0d0 - chi1 * sqom2)
25560        MomoFac2 = (1.0d0 - chi2 * sqom1)
25561        RR1  = ( R1 * R1 ) / MomoFac1
25562        RR2  = ( R2 * R2 ) / MomoFac2
25563        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25564        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
25565        fgb1 = sqrt( RR1 + a12sq * ee1 )
25566        fgb2 = sqrt( RR2 + a12sq * ee2 )
25567        epol = 332.0d0 * eps_inout_fac * ( &
25568       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
25569 !c!       epol = 0.0d0
25570        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
25571              / (fgb1 ** 5.0d0)
25572        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
25573              / (fgb2 ** 5.0d0)
25574        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
25575            / ( 2.0d0 * fgb1 )
25576        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
25577            / ( 2.0d0 * fgb2 )
25578        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
25579             * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
25580        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
25581             * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
25582        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25583 !c!       dPOLdR1 = 0.0d0
25584        dPOLdR2 = dPOLdFGB2 * dFGBdR2
25585 !c!       dPOLdR2 = 0.0d0
25586        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25587 !c!       dPOLdOM1 = 0.0d0
25588        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25589 !c!       dPOLdOM2 = 0.0d0
25590 !c!-------------------------------------------------------------------
25591 !c! Elj
25592 !c! Lennard-Jones 6-12 interaction between heads
25593        pom = (pis / Rhead)**6.0d0
25594        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25595 !c! derivative of Elj is Glj
25596        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
25597            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
25598 !c!-------------------------------------------------------------------
25599 !c! Return the results
25600 !c! These things do the dRdX derivatives, that is
25601 !c! allow us to change what we see from function that changes with
25602 !c! distance to function that changes with LOCATION (of the interaction
25603 !c! site)
25604        DO k = 1, 3
25605       erhead(k) = Rhead_distance(k)/Rhead
25606       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25607       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25608        END DO
25609
25610        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25611        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25612        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25613        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25614        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
25615        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25616        facd1 = d1 * vbld_inv(i+nres)
25617        facd2 = d2 * vbld_inv(j+nres)
25618        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25619        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25620
25621 !c! Now we add appropriate partial derivatives (one in each dimension)
25622        DO k = 1, 3
25623       hawk   = (erhead_tail(k,1) + &
25624       facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
25625       condor = (erhead_tail(k,2) + &
25626       facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
25627
25628       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25629       gvdwx(k,i) = gvdwx(k,i) &
25630               - dGCLdR * pom&
25631               - dGGBdR * pom&
25632               - dGCVdR * pom&
25633               - dPOLdR1 * hawk&
25634               - dPOLdR2 * (erhead_tail(k,2)&
25635       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
25636               - dGLJdR * pom
25637
25638       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25639       gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom&
25640                + dGGBdR * pom+ dGCVdR * pom&
25641               + dPOLdR1 * (erhead_tail(k,1)&
25642       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))&
25643               + dPOLdR2 * condor + dGLJdR * pom
25644
25645       gvdwc(k,i) = gvdwc(k,i)  &
25646               - dGCLdR * erhead(k)&
25647               - dGGBdR * erhead(k)&
25648               - dGCVdR * erhead(k)&
25649               - dPOLdR1 * erhead_tail(k,1)&
25650               - dPOLdR2 * erhead_tail(k,2)&
25651               - dGLJdR * erhead(k)
25652
25653       gvdwc(k,j) = gvdwc(k,j)         &
25654               + dGCLdR * erhead(k) &
25655               + dGGBdR * erhead(k) &
25656               + dGCVdR * erhead(k) &
25657               + dPOLdR1 * erhead_tail(k,1) &
25658               + dPOLdR2 * erhead_tail(k,2)&
25659               + dGLJdR * erhead(k)
25660
25661        END DO
25662        RETURN
25663       END SUBROUTINE eqq
25664
25665       SUBROUTINE eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
25666       use calc_data
25667       use comm_momo
25668        real (kind=8) ::  facd3, facd4, federmaus, adler,&
25669        Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
25670 !       integer :: k
25671 !c! Epol and Gpol analytical parameters
25672        alphapol1 = alphapolcat(itypi,itypj)
25673        alphapol2 = alphapolcat(itypj,itypi)
25674 !c! Fisocav and Gisocav analytical parameters
25675        al1  = alphisocat(1,itypi,itypj)
25676        al2  = alphisocat(2,itypi,itypj)
25677        al3  = alphisocat(3,itypi,itypj)
25678        al4  = alphisocat(4,itypi,itypj)
25679        csig = (1.0d0  &
25680          / dsqrt(sigiso1cat(itypi, itypj)**2.0d0 &
25681          + sigiso2cat(itypi,itypj)**2.0d0))
25682 !c!
25683        pis  = sig0headcat(itypi,itypj)
25684        eps_head = epsheadcat(itypi,itypj)
25685        Rhead_sq = Rhead * Rhead
25686 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25687 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25688        R1 = 0.0d0
25689        R2 = 0.0d0
25690        DO k = 1, 3
25691 !c! Calculate head-to-tail distances needed by Epol
25692       R1=R1+(ctail(k,2)-chead(k,1))**2
25693       R2=R2+(chead(k,2)-ctail(k,1))**2
25694        END DO
25695 !c! Pitagoras
25696        R1 = dsqrt(R1)
25697        R2 = dsqrt(R2)
25698
25699 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25700 !c!     &        +dhead(1,1,itypi,itypj))**2))
25701 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25702 !c!     &        +dhead(2,1,itypi,itypj))**2))
25703
25704 !c!-------------------------------------------------------------------
25705 !c! Coulomb electrostatic interaction
25706        Ecl = (332.0d0 * Qij) / Rhead
25707 !c! derivative of Ecl is Gcl...
25708        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
25709        dGCLdOM1 = 0.0d0
25710        dGCLdOM2 = 0.0d0
25711        dGCLdOM12 = 0.0d0
25712        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
25713        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
25714        debkap=debaykapcat(itypi,itypj)
25715        Egb = -(332.0d0 * Qij *&
25716       (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
25717 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
25718 !c! Derivative of Egb is Ggb...
25719        dGGBdFGB = -(-332.0d0 * Qij * &
25720        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
25721        -(332.0d0 * Qij *&
25722       (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
25723        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
25724        dGGBdR = dGGBdFGB * dFGBdR
25725 !c!-------------------------------------------------------------------
25726 !c! Fisocav - isotropic cavity creation term
25727 !c! or "how much energy it costs to put charged head in water"
25728        pom = Rhead * csig
25729        top = al1 * (dsqrt(pom) + al2 * pom - al3)
25730        bot = (1.0d0 + al4 * pom**12.0d0)
25731        botsq = bot * bot
25732        FisoCav = top / bot
25733 !      write (*,*) "Rhead = ",Rhead
25734 !      write (*,*) "csig = ",csig
25735 !      write (*,*) "pom = ",pom
25736 !      write (*,*) "al1 = ",al1
25737 !      write (*,*) "al2 = ",al2
25738 !      write (*,*) "al3 = ",al3
25739 !      write (*,*) "al4 = ",al4
25740 !        write (*,*) "top = ",top
25741 !        write (*,*) "bot = ",bot
25742 !c! Derivative of Fisocav is GCV...
25743        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
25744        dbot = 12.0d0 * al4 * pom ** 11.0d0
25745        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
25746 !c!-------------------------------------------------------------------
25747 !c! Epol
25748 !c! Polarization energy - charged heads polarize hydrophobic "neck"
25749        MomoFac1 = (1.0d0 - chi1 * sqom2)
25750        MomoFac2 = (1.0d0 - chi2 * sqom1)
25751        RR1  = ( R1 * R1 ) / MomoFac1
25752        RR2  = ( R2 * R2 ) / MomoFac2
25753        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25754        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
25755        fgb1 = sqrt( RR1 + a12sq * ee1 )
25756        fgb2 = sqrt( RR2 + a12sq * ee2 )
25757        epol = 332.0d0 * eps_inout_fac * ( &
25758       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
25759 !c!       epol = 0.0d0
25760        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
25761              / (fgb1 ** 5.0d0)
25762        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
25763              / (fgb2 ** 5.0d0)
25764        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
25765            / ( 2.0d0 * fgb1 )
25766        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
25767            / ( 2.0d0 * fgb2 )
25768        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
25769             * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
25770        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
25771             * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
25772        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25773 !c!       dPOLdR1 = 0.0d0
25774        dPOLdR2 = dPOLdFGB2 * dFGBdR2
25775 !c!       dPOLdR2 = 0.0d0
25776        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25777 !c!       dPOLdOM1 = 0.0d0
25778        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25779 !c!       dPOLdOM2 = 0.0d0
25780 !c!-------------------------------------------------------------------
25781 !c! Elj
25782 !c! Lennard-Jones 6-12 interaction between heads
25783        pom = (pis / Rhead)**6.0d0
25784        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25785 !c! derivative of Elj is Glj
25786        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
25787            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
25788 !c!-------------------------------------------------------------------
25789 !c! Return the results
25790 !c! These things do the dRdX derivatives, that is
25791 !c! allow us to change what we see from function that changes with
25792 !c! distance to function that changes with LOCATION (of the interaction
25793 !c! site)
25794        DO k = 1, 3
25795       erhead(k) = Rhead_distance(k)/Rhead
25796       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25797       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25798        END DO
25799
25800        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25801        erdxj = scalar( erhead(1), dC_norm(1,j) )
25802        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25803        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
25804        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
25805        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25806        facd1 = d1 * vbld_inv(i+nres)
25807        facd2 = d2 * vbld_inv(j)
25808        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
25809        facd4 = dtailcat(2,itypi,itypj) * vbld_inv(j)
25810
25811 !c! Now we add appropriate partial derivatives (one in each dimension)
25812        DO k = 1, 3
25813       hawk   = (erhead_tail(k,1) + &
25814       facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
25815       condor = (erhead_tail(k,2) + &
25816       facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
25817
25818       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25819       gradpepcatx(k,i) = gradpepcatx(k,i) &
25820               - dGCLdR * pom&
25821               - dGGBdR * pom&
25822               - dGCVdR * pom&
25823               - dPOLdR1 * hawk&
25824               - dPOLdR2 * (erhead_tail(k,2)&
25825       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
25826               - dGLJdR * pom
25827
25828       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
25829 !        gradpepcatx(k,j) = gradpepcatx(k,j)+ dGCLdR * pom&
25830 !                   + dGGBdR * pom+ dGCVdR * pom&
25831 !                  + dPOLdR1 * (erhead_tail(k,1)&
25832 !      -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j)))&
25833 !                  + dPOLdR2 * condor + dGLJdR * pom
25834
25835       gradpepcat(k,i) = gradpepcat(k,i)  &
25836               - dGCLdR * erhead(k)&
25837               - dGGBdR * erhead(k)&
25838               - dGCVdR * erhead(k)&
25839               - dPOLdR1 * erhead_tail(k,1)&
25840               - dPOLdR2 * erhead_tail(k,2)&
25841               - dGLJdR * erhead(k)
25842
25843       gradpepcat(k,j) = gradpepcat(k,j)         &
25844               + dGCLdR * erhead(k) &
25845               + dGGBdR * erhead(k) &
25846               + dGCVdR * erhead(k) &
25847               + dPOLdR1 * erhead_tail(k,1) &
25848               + dPOLdR2 * erhead_tail(k,2)&
25849               + dGLJdR * erhead(k)
25850
25851        END DO
25852        RETURN
25853       END SUBROUTINE eqq_cat
25854 !c!-------------------------------------------------------------------
25855       SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
25856       use comm_momo
25857       use calc_data
25858
25859        double precision eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad
25860        double precision ener(4)
25861        double precision dcosom1(3),dcosom2(3)
25862 !c! used in Epol derivatives
25863        double precision facd3, facd4
25864        double precision federmaus, adler
25865        integer istate,ii,jj
25866        real (kind=8) :: Fgb
25867 !       print *,"CALLING EQUAD"
25868 !c! Epol and Gpol analytical parameters
25869        alphapol1 = alphapol(itypi,itypj)
25870        alphapol2 = alphapol(itypj,itypi)
25871 !c! Fisocav and Gisocav analytical parameters
25872        al1  = alphiso(1,itypi,itypj)
25873        al2  = alphiso(2,itypi,itypj)
25874        al3  = alphiso(3,itypi,itypj)
25875        al4  = alphiso(4,itypi,itypj)
25876        csig = (1.0d0 / dsqrt(sigiso1(itypi, itypj)**2.0d0&
25877           + sigiso2(itypi,itypj)**2.0d0))
25878 !c!
25879        w1   = wqdip(1,itypi,itypj)
25880        w2   = wqdip(2,itypi,itypj)
25881        pis  = sig0head(itypi,itypj)
25882        eps_head = epshead(itypi,itypj)
25883 !c! First things first:
25884 !c! We need to do sc_grad's job with GB and Fcav
25885        eom1  = eps2der * eps2rt_om1 &
25886            - 2.0D0 * alf1 * eps3der&
25887            + sigder * sigsq_om1&
25888            + dCAVdOM1
25889        eom2  = eps2der * eps2rt_om2 &
25890            + 2.0D0 * alf2 * eps3der&
25891            + sigder * sigsq_om2&
25892            + dCAVdOM2
25893        eom12 =  evdwij  * eps1_om12 &
25894            + eps2der * eps2rt_om12 &
25895            - 2.0D0 * alf12 * eps3der&
25896            + sigder *sigsq_om12&
25897            + dCAVdOM12
25898 !c! now some magical transformations to project gradient into
25899 !c! three cartesian vectors
25900        DO k = 1, 3
25901       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25902       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
25903       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25904 !c! this acts on hydrophobic center of interaction
25905       gvdwx(k,i)= gvdwx(k,i) - gg(k) &
25906               + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
25907               + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25908       gvdwx(k,j)= gvdwx(k,j) + gg(k) &
25909               + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))&
25910               + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25911 !c! this acts on Calpha
25912       gvdwc(k,i)=gvdwc(k,i)-gg(k)
25913       gvdwc(k,j)=gvdwc(k,j)+gg(k)
25914        END DO
25915 !c! sc_grad is done, now we will compute
25916        eheadtail = 0.0d0
25917        eom1 = 0.0d0
25918        eom2 = 0.0d0
25919        eom12 = 0.0d0
25920        DO istate = 1, nstate(itypi,itypj)
25921 !c*************************************************************
25922       IF (istate.ne.1) THEN
25923        IF (istate.lt.3) THEN
25924         ii = 1
25925        ELSE
25926         ii = 2
25927        END IF
25928       jj = istate/ii
25929       d1 = dhead(1,ii,itypi,itypj)
25930       d2 = dhead(2,jj,itypi,itypj)
25931       DO k = 1,3
25932        chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
25933        chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
25934        Rhead_distance(k) = chead(k,2) - chead(k,1)
25935       END DO
25936 !c! pitagoras (root of sum of squares)
25937       Rhead = dsqrt( &
25938              (Rhead_distance(1)*Rhead_distance(1))  &
25939            + (Rhead_distance(2)*Rhead_distance(2))  &
25940            + (Rhead_distance(3)*Rhead_distance(3)))
25941       END IF
25942       Rhead_sq = Rhead * Rhead
25943
25944 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25945 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25946       R1 = 0.0d0
25947       R2 = 0.0d0
25948       DO k = 1, 3
25949 !c! Calculate head-to-tail distances
25950        R1=R1+(ctail(k,2)-chead(k,1))**2
25951        R2=R2+(chead(k,2)-ctail(k,1))**2
25952       END DO
25953 !c! Pitagoras
25954       R1 = dsqrt(R1)
25955       R2 = dsqrt(R2)
25956       Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
25957 !c!        Ecl = 0.0d0
25958 !c!        write (*,*) "Ecl = ", Ecl
25959 !c! derivative of Ecl is Gcl...
25960       dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
25961 !c!        dGCLdR = 0.0d0
25962       dGCLdOM1 = 0.0d0
25963       dGCLdOM2 = 0.0d0
25964       dGCLdOM12 = 0.0d0
25965 !c!-------------------------------------------------------------------
25966 !c! Generalised Born Solvent Polarization
25967       ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
25968       Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
25969       Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
25970 !c!        Egb = 0.0d0
25971 !c!      write (*,*) "a1*a2 = ", a12sq
25972 !c!      write (*,*) "Rhead = ", Rhead
25973 !c!      write (*,*) "Rhead_sq = ", Rhead_sq
25974 !c!      write (*,*) "ee = ", ee
25975 !c!      write (*,*) "Fgb = ", Fgb
25976 !c!      write (*,*) "fac = ", eps_inout_fac
25977 !c!      write (*,*) "Qij = ", Qij
25978 !c!      write (*,*) "Egb = ", Egb
25979 !c! Derivative of Egb is Ggb...
25980 !c! dFGBdR is used by Quad's later...
25981       dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
25982       dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )&
25983              / ( 2.0d0 * Fgb )
25984       dGGBdR = dGGBdFGB * dFGBdR
25985 !c!        dGGBdR = 0.0d0
25986 !c!-------------------------------------------------------------------
25987 !c! Fisocav - isotropic cavity creation term
25988       pom = Rhead * csig
25989       top = al1 * (dsqrt(pom) + al2 * pom - al3)
25990       bot = (1.0d0 + al4 * pom**12.0d0)
25991       botsq = bot * bot
25992       FisoCav = top / bot
25993       dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
25994       dbot = 12.0d0 * al4 * pom ** 11.0d0
25995       dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
25996 !c!        dGCVdR = 0.0d0
25997 !c!-------------------------------------------------------------------
25998 !c! Polarization energy
25999 !c! Epol
26000       MomoFac1 = (1.0d0 - chi1 * sqom2)
26001       MomoFac2 = (1.0d0 - chi2 * sqom1)
26002       RR1  = ( R1 * R1 ) / MomoFac1
26003       RR2  = ( R2 * R2 ) / MomoFac2
26004       ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26005       ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26006       fgb1 = sqrt( RR1 + a12sq * ee1 )
26007       fgb2 = sqrt( RR2 + a12sq * ee2 )
26008       epol = 332.0d0 * eps_inout_fac * (&
26009       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26010 !c!        epol = 0.0d0
26011 !c! derivative of Epol is Gpol...
26012       dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26013               / (fgb1 ** 5.0d0)
26014       dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26015               / (fgb2 ** 5.0d0)
26016       dFGBdR1 = ( (R1 / MomoFac1) &
26017             * ( 2.0d0 - (0.5d0 * ee1) ) )&
26018             / ( 2.0d0 * fgb1 )
26019       dFGBdR2 = ( (R2 / MomoFac2) &
26020             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26021             / ( 2.0d0 * fgb2 )
26022       dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26023              * ( 2.0d0 - 0.5d0 * ee1) ) &
26024              / ( 2.0d0 * fgb1 )
26025       dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26026              * ( 2.0d0 - 0.5d0 * ee2) ) &
26027              / ( 2.0d0 * fgb2 )
26028       dPOLdR1 = dPOLdFGB1 * dFGBdR1
26029 !c!        dPOLdR1 = 0.0d0
26030       dPOLdR2 = dPOLdFGB2 * dFGBdR2
26031 !c!        dPOLdR2 = 0.0d0
26032       dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26033 !c!        dPOLdOM1 = 0.0d0
26034       dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26035       pom = (pis / Rhead)**6.0d0
26036       Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26037 !c!        Elj = 0.0d0
26038 !c! derivative of Elj is Glj
26039       dGLJdR = 4.0d0 * eps_head &
26040           * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26041           +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26042 !c!        dGLJdR = 0.0d0
26043 !c!-------------------------------------------------------------------
26044 !c! Equad
26045        IF (Wqd.ne.0.0d0) THEN
26046       Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) &
26047            - 37.5d0  * ( sqom1 + sqom2 ) &
26048            + 157.5d0 * ( sqom1 * sqom2 ) &
26049            - 45.0d0  * om1*om2*om12
26050       fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
26051       Equad = fac * Beta1
26052 !c!        Equad = 0.0d0
26053 !c! derivative of Equad...
26054       dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
26055 !c!        dQUADdR = 0.0d0
26056       dQUADdOM1 = fac* (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
26057 !c!        dQUADdOM1 = 0.0d0
26058       dQUADdOM2 = fac* (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
26059 !c!        dQUADdOM2 = 0.0d0
26060       dQUADdOM12 = fac * ( 6.0d0*om12 - 45.0d0*om1*om2 )
26061        ELSE
26062        Beta1 = 0.0d0
26063        Equad = 0.0d0
26064       END IF
26065 !c!-------------------------------------------------------------------
26066 !c! Return the results
26067 !c! Angular stuff
26068       eom1 = dPOLdOM1 + dQUADdOM1
26069       eom2 = dPOLdOM2 + dQUADdOM2
26070       eom12 = dQUADdOM12
26071 !c! now some magical transformations to project gradient into
26072 !c! three cartesian vectors
26073       DO k = 1, 3
26074        dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
26075        dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
26076        tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
26077       END DO
26078 !c! Radial stuff
26079       DO k = 1, 3
26080        erhead(k) = Rhead_distance(k)/Rhead
26081        erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26082        erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26083       END DO
26084       erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26085       erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26086       bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26087       federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26088       eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26089       adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26090       facd1 = d1 * vbld_inv(i+nres)
26091       facd2 = d2 * vbld_inv(j+nres)
26092       facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26093       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26094       DO k = 1, 3
26095        hawk   = erhead_tail(k,1) + &
26096        facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
26097        condor = erhead_tail(k,2) + &
26098        facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
26099
26100        pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26101 !c! this acts on hydrophobic center of interaction
26102        gheadtail(k,1,1) = gheadtail(k,1,1) &
26103                    - dGCLdR * pom &
26104                    - dGGBdR * pom &
26105                    - dGCVdR * pom &
26106                    - dPOLdR1 * hawk &
26107                    - dPOLdR2 * (erhead_tail(k,2) &
26108       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26109                    - dGLJdR * pom &
26110                    - dQUADdR * pom&
26111                    - tuna(k) &
26112              + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
26113              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26114
26115        pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26116 !c! this acts on hydrophobic center of interaction
26117        gheadtail(k,2,1) = gheadtail(k,2,1)  &
26118                    + dGCLdR * pom      &
26119                    + dGGBdR * pom      &
26120                    + dGCVdR * pom      &
26121                    + dPOLdR1 * (erhead_tail(k,1) &
26122       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
26123                    + dPOLdR2 * condor &
26124                    + dGLJdR * pom &
26125                    + dQUADdR * pom &
26126                    + tuna(k) &
26127              + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
26128              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26129
26130 !c! this acts on Calpha
26131        gheadtail(k,3,1) = gheadtail(k,3,1)  &
26132                    - dGCLdR * erhead(k)&
26133                    - dGGBdR * erhead(k)&
26134                    - dGCVdR * erhead(k)&
26135                    - dPOLdR1 * erhead_tail(k,1)&
26136                    - dPOLdR2 * erhead_tail(k,2)&
26137                    - dGLJdR * erhead(k) &
26138                    - dQUADdR * erhead(k)&
26139                    - tuna(k)
26140 !c! this acts on Calpha
26141        gheadtail(k,4,1) = gheadtail(k,4,1)   &
26142                     + dGCLdR * erhead(k) &
26143                     + dGGBdR * erhead(k) &
26144                     + dGCVdR * erhead(k) &
26145                     + dPOLdR1 * erhead_tail(k,1) &
26146                     + dPOLdR2 * erhead_tail(k,2) &
26147                     + dGLJdR * erhead(k) &
26148                     + dQUADdR * erhead(k)&
26149                     + tuna(k)
26150       END DO
26151       ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
26152       eheadtail = eheadtail &
26153               + wstate(istate, itypi, itypj) &
26154               * dexp(-betaT * ener(istate))
26155 !c! foreach cartesian dimension
26156       DO k = 1, 3
26157 !c! foreach of two gvdwx and gvdwc
26158        DO l = 1, 4
26159         gheadtail(k,l,2) = gheadtail(k,l,2)  &
26160                      + wstate( istate, itypi, itypj ) &
26161                      * dexp(-betaT * ener(istate)) &
26162                      * gheadtail(k,l,1)
26163         gheadtail(k,l,1) = 0.0d0
26164        END DO
26165       END DO
26166        END DO
26167 !c! Here ended the gigantic DO istate = 1, 4, which starts
26168 !c! at the beggining of the subroutine
26169
26170        DO k = 1, 3
26171       DO l = 1, 4
26172        gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
26173       END DO
26174       gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
26175       gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
26176       gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
26177       gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
26178       DO l = 1, 4
26179        gheadtail(k,l,1) = 0.0d0
26180        gheadtail(k,l,2) = 0.0d0
26181       END DO
26182        END DO
26183        eheadtail = (-dlog(eheadtail)) / betaT
26184        dPOLdOM1 = 0.0d0
26185        dPOLdOM2 = 0.0d0
26186        dQUADdOM1 = 0.0d0
26187        dQUADdOM2 = 0.0d0
26188        dQUADdOM12 = 0.0d0
26189        RETURN
26190       END SUBROUTINE energy_quad
26191 !!-----------------------------------------------------------
26192       SUBROUTINE eqn(Epol)
26193       use comm_momo
26194       use calc_data
26195
26196       double precision  facd4, federmaus,epol
26197       alphapol1 = alphapol(itypi,itypj)
26198 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26199        R1 = 0.0d0
26200        DO k = 1, 3
26201 !c! Calculate head-to-tail distances
26202       R1=R1+(ctail(k,2)-chead(k,1))**2
26203        END DO
26204 !c! Pitagoras
26205        R1 = dsqrt(R1)
26206
26207 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26208 !c!     &        +dhead(1,1,itypi,itypj))**2))
26209 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26210 !c!     &        +dhead(2,1,itypi,itypj))**2))
26211 !c--------------------------------------------------------------------
26212 !c Polarization energy
26213 !c Epol
26214        MomoFac1 = (1.0d0 - chi1 * sqom2)
26215        RR1  = R1 * R1 / MomoFac1
26216        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26217        fgb1 = sqrt( RR1 + a12sq * ee1)
26218        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26219        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26220              / (fgb1 ** 5.0d0)
26221        dFGBdR1 = ( (R1 / MomoFac1) &
26222             * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26223             / ( 2.0d0 * fgb1 )
26224        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26225             * (2.0d0 - 0.5d0 * ee1) ) &
26226             / (2.0d0 * fgb1)
26227        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26228 !c!       dPOLdR1 = 0.0d0
26229        dPOLdOM1 = 0.0d0
26230        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26231        DO k = 1, 3
26232       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26233        END DO
26234        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26235        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26236        facd1 = d1 * vbld_inv(i+nres)
26237        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26238
26239        DO k = 1, 3
26240       hawk = (erhead_tail(k,1) + &
26241       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26242
26243       gvdwx(k,i) = gvdwx(k,i) &
26244                - dPOLdR1 * hawk
26245       gvdwx(k,j) = gvdwx(k,j) &
26246                + dPOLdR1 * (erhead_tail(k,1) &
26247        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
26248
26249       gvdwc(k,i) = gvdwc(k,i)  - dPOLdR1 * erhead_tail(k,1)
26250       gvdwc(k,j) = gvdwc(k,j)  + dPOLdR1 * erhead_tail(k,1)
26251
26252        END DO
26253        RETURN
26254       END SUBROUTINE eqn
26255       SUBROUTINE enq(Epol)
26256       use calc_data
26257       use comm_momo
26258        double precision facd3, adler,epol
26259        alphapol2 = alphapol(itypj,itypi)
26260 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26261        R2 = 0.0d0
26262        DO k = 1, 3
26263 !c! Calculate head-to-tail distances
26264       R2=R2+(chead(k,2)-ctail(k,1))**2
26265        END DO
26266 !c! Pitagoras
26267        R2 = dsqrt(R2)
26268
26269 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26270 !c!     &        +dhead(1,1,itypi,itypj))**2))
26271 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26272 !c!     &        +dhead(2,1,itypi,itypj))**2))
26273 !c------------------------------------------------------------------------
26274 !c Polarization energy
26275        MomoFac2 = (1.0d0 - chi2 * sqom1)
26276        RR2  = R2 * R2 / MomoFac2
26277        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26278        fgb2 = sqrt(RR2  + a12sq * ee2)
26279        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26280        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26281             / (fgb2 ** 5.0d0)
26282        dFGBdR2 = ( (R2 / MomoFac2)  &
26283             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26284             / (2.0d0 * fgb2)
26285        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26286             * (2.0d0 - 0.5d0 * ee2) ) &
26287             / (2.0d0 * fgb2)
26288        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26289 !c!       dPOLdR2 = 0.0d0
26290        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26291 !c!       dPOLdOM1 = 0.0d0
26292        dPOLdOM2 = 0.0d0
26293 !c!-------------------------------------------------------------------
26294 !c! Return the results
26295 !c! (See comments in Eqq)
26296        DO k = 1, 3
26297       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26298        END DO
26299        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26300        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26301        facd2 = d2 * vbld_inv(j+nres)
26302        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26303        DO k = 1, 3
26304       condor = (erhead_tail(k,2) &
26305        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26306
26307       gvdwx(k,i) = gvdwx(k,i) &
26308                - dPOLdR2 * (erhead_tail(k,2) &
26309        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
26310       gvdwx(k,j) = gvdwx(k,j)   &
26311                + dPOLdR2 * condor
26312
26313       gvdwc(k,i) = gvdwc(k,i) &
26314                - dPOLdR2 * erhead_tail(k,2)
26315       gvdwc(k,j) = gvdwc(k,j) &
26316                + dPOLdR2 * erhead_tail(k,2)
26317
26318        END DO
26319       RETURN
26320       END SUBROUTINE enq
26321
26322       SUBROUTINE enq_cat(Epol)
26323       use calc_data
26324       use comm_momo
26325        double precision facd3, adler,epol
26326        alphapol2 = alphapolcat(itypj,itypi)
26327 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26328        R2 = 0.0d0
26329        DO k = 1, 3
26330 !c! Calculate head-to-tail distances
26331       R2=R2+(chead(k,2)-ctail(k,1))**2
26332        END DO
26333 !c! Pitagoras
26334        R2 = dsqrt(R2)
26335
26336 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26337 !c!     &        +dhead(1,1,itypi,itypj))**2))
26338 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26339 !c!     &        +dhead(2,1,itypi,itypj))**2))
26340 !c------------------------------------------------------------------------
26341 !c Polarization energy
26342        MomoFac2 = (1.0d0 - chi2 * sqom1)
26343        RR2  = R2 * R2 / MomoFac2
26344        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26345        fgb2 = sqrt(RR2  + a12sq * ee2)
26346        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26347        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26348             / (fgb2 ** 5.0d0)
26349        dFGBdR2 = ( (R2 / MomoFac2)  &
26350             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26351             / (2.0d0 * fgb2)
26352        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26353             * (2.0d0 - 0.5d0 * ee2) ) &
26354             / (2.0d0 * fgb2)
26355        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26356 !c!       dPOLdR2 = 0.0d0
26357        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26358 !c!       dPOLdOM1 = 0.0d0
26359        dPOLdOM2 = 0.0d0
26360
26361 !c!-------------------------------------------------------------------
26362 !c! Return the results
26363 !c! (See comments in Eqq)
26364        DO k = 1, 3
26365       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26366        END DO
26367        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
26368        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26369        facd2 = d2 * vbld_inv(j+nres)
26370        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
26371        DO k = 1, 3
26372       condor = (erhead_tail(k,2) &
26373        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
26374
26375       gradpepcatx(k,i) = gradpepcatx(k,i) &
26376                - dPOLdR2 * (erhead_tail(k,2) &
26377        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
26378 !        gradpepcatx(k,j) = gradpepcatx(k,j)   &
26379 !                   + dPOLdR2 * condor
26380
26381       gradpepcat(k,i) = gradpepcat(k,i) &
26382                - dPOLdR2 * erhead_tail(k,2)
26383       gradpepcat(k,j) = gradpepcat(k,j) &
26384                + dPOLdR2 * erhead_tail(k,2)
26385
26386        END DO
26387       RETURN
26388       END SUBROUTINE enq_cat
26389
26390       SUBROUTINE eqd(Ecl,Elj,Epol)
26391       use calc_data
26392       use comm_momo
26393        double precision  facd4, federmaus,ecl,elj,epol
26394        alphapol1 = alphapol(itypi,itypj)
26395        w1        = wqdip(1,itypi,itypj)
26396        w2        = wqdip(2,itypi,itypj)
26397        pis       = sig0head(itypi,itypj)
26398        eps_head   = epshead(itypi,itypj)
26399 !c!-------------------------------------------------------------------
26400 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26401        R1 = 0.0d0
26402        DO k = 1, 3
26403 !c! Calculate head-to-tail distances
26404       R1=R1+(ctail(k,2)-chead(k,1))**2
26405        END DO
26406 !c! Pitagoras
26407        R1 = dsqrt(R1)
26408
26409 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26410 !c!     &        +dhead(1,1,itypi,itypj))**2))
26411 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26412 !c!     &        +dhead(2,1,itypi,itypj))**2))
26413
26414 !c!-------------------------------------------------------------------
26415 !c! ecl
26416        sparrow  = w1 * Qi * om1
26417        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
26418        Ecl = sparrow / Rhead**2.0d0 &
26419          - hawk    / Rhead**4.0d0
26420        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26421              + 4.0d0 * hawk    / Rhead**5.0d0
26422 !c! dF/dom1
26423        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
26424 !c! dF/dom2
26425        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
26426 !c--------------------------------------------------------------------
26427 !c Polarization energy
26428 !c Epol
26429        MomoFac1 = (1.0d0 - chi1 * sqom2)
26430        RR1  = R1 * R1 / MomoFac1
26431        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26432        fgb1 = sqrt( RR1 + a12sq * ee1)
26433        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26434 !c!       epol = 0.0d0
26435 !c!------------------------------------------------------------------
26436 !c! derivative of Epol is Gpol...
26437        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26438              / (fgb1 ** 5.0d0)
26439        dFGBdR1 = ( (R1 / MomoFac1)  &
26440            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26441            / ( 2.0d0 * fgb1 )
26442        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26443              * (2.0d0 - 0.5d0 * ee1) ) &
26444              / (2.0d0 * fgb1)
26445        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26446 !c!       dPOLdR1 = 0.0d0
26447        dPOLdOM1 = 0.0d0
26448        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26449 !c!       dPOLdOM2 = 0.0d0
26450 !c!-------------------------------------------------------------------
26451 !c! Elj
26452        pom = (pis / Rhead)**6.0d0
26453        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26454 !c! derivative of Elj is Glj
26455        dGLJdR = 4.0d0 * eps_head &
26456         * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26457         +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26458        DO k = 1, 3
26459       erhead(k) = Rhead_distance(k)/Rhead
26460       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26461        END DO
26462
26463        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26464        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26465        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26466        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26467        facd1 = d1 * vbld_inv(i+nres)
26468        facd2 = d2 * vbld_inv(j+nres)
26469        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26470
26471        DO k = 1, 3
26472       hawk = (erhead_tail(k,1) +  &
26473       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26474
26475       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26476       gvdwx(k,i) = gvdwx(k,i)  &
26477                - dGCLdR * pom&
26478                - dPOLdR1 * hawk &
26479                - dGLJdR * pom
26480
26481       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26482       gvdwx(k,j) = gvdwx(k,j)    &
26483                + dGCLdR * pom  &
26484                + dPOLdR1 * (erhead_tail(k,1) &
26485        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
26486                + dGLJdR * pom
26487
26488
26489       gvdwc(k,i) = gvdwc(k,i)          &
26490                - dGCLdR * erhead(k)  &
26491                - dPOLdR1 * erhead_tail(k,1) &
26492                - dGLJdR * erhead(k)
26493
26494       gvdwc(k,j) = gvdwc(k,j)          &
26495                + dGCLdR * erhead(k)  &
26496                + dPOLdR1 * erhead_tail(k,1) &
26497                + dGLJdR * erhead(k)
26498
26499        END DO
26500        RETURN
26501       END SUBROUTINE eqd
26502       SUBROUTINE edq(Ecl,Elj,Epol)
26503 !       IMPLICIT NONE
26504        use comm_momo
26505       use calc_data
26506
26507       double precision  facd3, adler,ecl,elj,epol
26508        alphapol2 = alphapol(itypj,itypi)
26509        w1        = wqdip(1,itypi,itypj)
26510        w2        = wqdip(2,itypi,itypj)
26511        pis       = sig0head(itypi,itypj)
26512        eps_head  = epshead(itypi,itypj)
26513 !c!-------------------------------------------------------------------
26514 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26515        R2 = 0.0d0
26516        DO k = 1, 3
26517 !c! Calculate head-to-tail distances
26518       R2=R2+(chead(k,2)-ctail(k,1))**2
26519        END DO
26520 !c! Pitagoras
26521        R2 = dsqrt(R2)
26522
26523 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26524 !c!     &        +dhead(1,1,itypi,itypj))**2))
26525 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26526 !c!     &        +dhead(2,1,itypi,itypj))**2))
26527
26528
26529 !c!-------------------------------------------------------------------
26530 !c! ecl
26531        sparrow  = w1 * Qj * om1
26532        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
26533        ECL = sparrow / Rhead**2.0d0 &
26534          - hawk    / Rhead**4.0d0
26535 !c!-------------------------------------------------------------------
26536 !c! derivative of ecl is Gcl
26537 !c! dF/dr part
26538        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26539              + 4.0d0 * hawk    / Rhead**5.0d0
26540 !c! dF/dom1
26541        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
26542 !c! dF/dom2
26543        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
26544 !c--------------------------------------------------------------------
26545 !c Polarization energy
26546 !c Epol
26547        MomoFac2 = (1.0d0 - chi2 * sqom1)
26548        RR2  = R2 * R2 / MomoFac2
26549        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26550        fgb2 = sqrt(RR2  + a12sq * ee2)
26551        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26552        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26553              / (fgb2 ** 5.0d0)
26554        dFGBdR2 = ( (R2 / MomoFac2)  &
26555              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26556              / (2.0d0 * fgb2)
26557        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26558             * (2.0d0 - 0.5d0 * ee2) ) &
26559             / (2.0d0 * fgb2)
26560        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26561 !c!       dPOLdR2 = 0.0d0
26562        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26563 !c!       dPOLdOM1 = 0.0d0
26564        dPOLdOM2 = 0.0d0
26565 !c!-------------------------------------------------------------------
26566 !c! Elj
26567        pom = (pis / Rhead)**6.0d0
26568        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26569 !c! derivative of Elj is Glj
26570        dGLJdR = 4.0d0 * eps_head &
26571          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26572          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26573 !c!-------------------------------------------------------------------
26574 !c! Return the results
26575 !c! (see comments in Eqq)
26576        DO k = 1, 3
26577       erhead(k) = Rhead_distance(k)/Rhead
26578       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26579        END DO
26580        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26581        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26582        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26583        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26584        facd1 = d1 * vbld_inv(i+nres)
26585        facd2 = d2 * vbld_inv(j+nres)
26586        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26587        DO k = 1, 3
26588       condor = (erhead_tail(k,2) &
26589        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26590
26591       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26592       gvdwx(k,i) = gvdwx(k,i) &
26593               - dGCLdR * pom &
26594               - dPOLdR2 * (erhead_tail(k,2) &
26595        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
26596               - dGLJdR * pom
26597
26598       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26599       gvdwx(k,j) = gvdwx(k,j) &
26600               + dGCLdR * pom &
26601               + dPOLdR2 * condor &
26602               + dGLJdR * pom
26603
26604
26605       gvdwc(k,i) = gvdwc(k,i) &
26606               - dGCLdR * erhead(k) &
26607               - dPOLdR2 * erhead_tail(k,2) &
26608               - dGLJdR * erhead(k)
26609
26610       gvdwc(k,j) = gvdwc(k,j) &
26611               + dGCLdR * erhead(k) &
26612               + dPOLdR2 * erhead_tail(k,2) &
26613               + dGLJdR * erhead(k)
26614
26615        END DO
26616        RETURN
26617       END SUBROUTINE edq
26618
26619       SUBROUTINE edq_cat(Ecl,Elj,Epol)
26620       use comm_momo
26621       use calc_data
26622
26623       double precision  facd3, adler,ecl,elj,epol
26624        alphapol2 = alphapolcat(itypj,itypi)
26625        w1        = wqdipcat(1,itypi,itypj)
26626        w2        = wqdipcat(2,itypi,itypj)
26627        pis       = sig0headcat(itypi,itypj)
26628        eps_head  = epsheadcat(itypi,itypj)
26629 !c!-------------------------------------------------------------------
26630 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26631        R2 = 0.0d0
26632        DO k = 1, 3
26633 !c! Calculate head-to-tail distances
26634       R2=R2+(chead(k,2)-ctail(k,1))**2
26635        END DO
26636 !c! Pitagoras
26637        R2 = dsqrt(R2)
26638
26639 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26640 !c!     &        +dhead(1,1,itypi,itypj))**2))
26641 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26642 !c!     &        +dhead(2,1,itypi,itypj))**2))
26643
26644
26645 !c!-------------------------------------------------------------------
26646 !c! ecl
26647        write(iout,*) "KURWA2",Rhead
26648        sparrow  = w1 * Qj * om1
26649        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
26650        ECL = sparrow / Rhead**2.0d0 &
26651          - hawk    / Rhead**4.0d0
26652 !c!-------------------------------------------------------------------
26653 !c! derivative of ecl is Gcl
26654 !c! dF/dr part
26655        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26656              + 4.0d0 * hawk    / Rhead**5.0d0
26657 !c! dF/dom1
26658        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
26659 !c! dF/dom2
26660        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
26661 !c--------------------------------------------------------------------
26662 !c--------------------------------------------------------------------
26663 !c Polarization energy
26664 !c Epol
26665        MomoFac2 = (1.0d0 - chi2 * sqom1)
26666        RR2  = R2 * R2 / MomoFac2
26667        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26668        fgb2 = sqrt(RR2  + a12sq * ee2)
26669        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26670        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26671              / (fgb2 ** 5.0d0)
26672        dFGBdR2 = ( (R2 / MomoFac2)  &
26673              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26674              / (2.0d0 * fgb2)
26675        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26676             * (2.0d0 - 0.5d0 * ee2) ) &
26677             / (2.0d0 * fgb2)
26678        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26679 !c!       dPOLdR2 = 0.0d0
26680        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26681 !c!       dPOLdOM1 = 0.0d0
26682        dPOLdOM2 = 0.0d0
26683 !c!-------------------------------------------------------------------
26684 !c! Elj
26685        pom = (pis / Rhead)**6.0d0
26686        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26687 !c! derivative of Elj is Glj
26688        dGLJdR = 4.0d0 * eps_head &
26689          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26690          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26691 !c!-------------------------------------------------------------------
26692
26693 !c! Return the results
26694 !c! (see comments in Eqq)
26695        DO k = 1, 3
26696       erhead(k) = Rhead_distance(k)/Rhead
26697       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26698        END DO
26699        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26700        erdxj = scalar( erhead(1), dC_norm(1,j) )
26701        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
26702        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26703        facd1 = d1 * vbld_inv(i+nres)
26704        facd2 = d2 * vbld_inv(j)
26705        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
26706        DO k = 1, 3
26707       condor = (erhead_tail(k,2) &
26708        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
26709
26710       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26711       gradpepcatx(k,i) = gradpepcatx(k,i) &
26712               - dGCLdR * pom &
26713               - dPOLdR2 * (erhead_tail(k,2) &
26714        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
26715               - dGLJdR * pom
26716
26717       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
26718 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
26719 !                  + dGCLdR * pom &
26720 !                  + dPOLdR2 * condor &
26721 !                  + dGLJdR * pom
26722
26723
26724       gradpepcat(k,i) = gradpepcat(k,i) &
26725               - dGCLdR * erhead(k) &
26726               - dPOLdR2 * erhead_tail(k,2) &
26727               - dGLJdR * erhead(k)
26728
26729       gradpepcat(k,j) = gradpepcat(k,j) &
26730               + dGCLdR * erhead(k) &
26731               + dPOLdR2 * erhead_tail(k,2) &
26732               + dGLJdR * erhead(k)
26733
26734        END DO
26735        RETURN
26736       END SUBROUTINE edq_cat
26737
26738       SUBROUTINE edq_cat_pep(Ecl,Elj,Epol)
26739       use comm_momo
26740       use calc_data
26741
26742       double precision  facd3, adler,ecl,elj,epol
26743        alphapol2 = alphapolcat(itypj,itypi)
26744        w1        = wqdipcat(1,itypi,itypj)
26745        w2        = wqdipcat(2,itypi,itypj)
26746        pis       = sig0headcat(itypi,itypj)
26747        eps_head  = epsheadcat(itypi,itypj)
26748 !c!-------------------------------------------------------------------
26749 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26750        R2 = 0.0d0
26751        DO k = 1, 3
26752 !c! Calculate head-to-tail distances
26753       R2=R2+(chead(k,2)-ctail(k,1))**2
26754        END DO
26755 !c! Pitagoras
26756        R2 = dsqrt(R2)
26757
26758 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26759 !c!     &        +dhead(1,1,itypi,itypj))**2))
26760 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26761 !c!     &        +dhead(2,1,itypi,itypj))**2))
26762
26763
26764 !c!-------------------------------------------------------------------
26765 !c! ecl
26766        sparrow  = w1 * Qj * om1
26767        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
26768 !       print *,"CO2", itypi,itypj
26769 !       print *,"CO?!.", w1,w2,Qj,om1
26770        ECL = sparrow / Rhead**2.0d0 &
26771          - hawk    / Rhead**4.0d0
26772 !c!-------------------------------------------------------------------
26773 !c! derivative of ecl is Gcl
26774 !c! dF/dr part
26775        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26776              + 4.0d0 * hawk    / Rhead**5.0d0
26777 !c! dF/dom1
26778        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
26779 !c! dF/dom2
26780        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
26781 !c--------------------------------------------------------------------
26782 !c--------------------------------------------------------------------
26783 !c Polarization energy
26784 !c Epol
26785        MomoFac2 = (1.0d0 - chi2 * sqom1)
26786        RR2  = R2 * R2 / MomoFac2
26787        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26788        fgb2 = sqrt(RR2  + a12sq * ee2)
26789        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26790        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26791              / (fgb2 ** 5.0d0)
26792        dFGBdR2 = ( (R2 / MomoFac2)  &
26793              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26794              / (2.0d0 * fgb2)
26795        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26796             * (2.0d0 - 0.5d0 * ee2) ) &
26797             / (2.0d0 * fgb2)
26798        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26799 !c!       dPOLdR2 = 0.0d0
26800        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26801 !c!       dPOLdOM1 = 0.0d0
26802        dPOLdOM2 = 0.0d0
26803 !c!-------------------------------------------------------------------
26804 !c! Elj
26805        pom = (pis / Rhead)**6.0d0
26806        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26807 !c! derivative of Elj is Glj
26808        dGLJdR = 4.0d0 * eps_head &
26809          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26810          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26811 !c!-------------------------------------------------------------------
26812
26813 !c! Return the results
26814 !c! (see comments in Eqq)
26815        DO k = 1, 3
26816       erhead(k) = Rhead_distance(k)/Rhead
26817       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26818        END DO
26819        erdxi = scalar( erhead(1), dC_norm(1,i) )
26820        erdxj = scalar( erhead(1), dC_norm(1,j) )
26821        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
26822        adler = scalar( erhead_tail(1,2), dC_norm(1,i) )
26823        facd1 = d1 * vbld_inv(i+1)/2.0
26824        facd2 = d2 * vbld_inv(j)
26825        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+1)/2.0
26826        DO k = 1, 3
26827       condor = (erhead_tail(k,2) &
26828        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
26829
26830       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i))
26831 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
26832 !                  - dGCLdR * pom &
26833 !                  - dPOLdR2 * (erhead_tail(k,2) &
26834 !       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
26835 !                  - dGLJdR * pom
26836
26837       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
26838 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
26839 !                  + dGCLdR * pom &
26840 !                  + dPOLdR2 * condor &
26841 !                  + dGLJdR * pom
26842
26843
26844       gradpepcat(k,i) = gradpepcat(k,i) +0.5d0*( &
26845               - dGCLdR * erhead(k) &
26846               - dPOLdR2 * erhead_tail(k,2) &
26847               - dGLJdR * erhead(k))
26848       gradpepcat(k,i+1) = gradpepcat(k,i+1) +0.5d0*( &
26849               - dGCLdR * erhead(k) &
26850               - dPOLdR2 * erhead_tail(k,2) &
26851               - dGLJdR * erhead(k))
26852
26853
26854       gradpepcat(k,j) = gradpepcat(k,j) &
26855               + dGCLdR * erhead(k) &
26856               + dPOLdR2 * erhead_tail(k,2) &
26857               + dGLJdR * erhead(k)
26858
26859        END DO
26860        RETURN
26861       END SUBROUTINE edq_cat_pep
26862
26863       SUBROUTINE edd(ECL)
26864 !       IMPLICIT NONE
26865        use comm_momo
26866       use calc_data
26867
26868        double precision ecl
26869 !c!       csig = sigiso(itypi,itypj)
26870        w1 = wqdip(1,itypi,itypj)
26871        w2 = wqdip(2,itypi,itypj)
26872 !c!-------------------------------------------------------------------
26873 !c! ECL
26874        fac = (om12 - 3.0d0 * om1 * om2)
26875        c1 = (w1 / (Rhead**3.0d0)) * fac
26876        c2 = (w2 / Rhead ** 6.0d0) &
26877         * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
26878        ECL = c1 - c2
26879 !c!       write (*,*) "w1 = ", w1
26880 !c!       write (*,*) "w2 = ", w2
26881 !c!       write (*,*) "om1 = ", om1
26882 !c!       write (*,*) "om2 = ", om2
26883 !c!       write (*,*) "om12 = ", om12
26884 !c!       write (*,*) "fac = ", fac
26885 !c!       write (*,*) "c1 = ", c1
26886 !c!       write (*,*) "c2 = ", c2
26887 !c!       write (*,*) "Ecl = ", Ecl
26888 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
26889 !c!       write (*,*) "c2_2 = ",
26890 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
26891 !c!-------------------------------------------------------------------
26892 !c! dervative of ECL is GCL...
26893 !c! dECL/dr
26894        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
26895        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
26896         * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
26897        dGCLdR = c1 - c2
26898 !c! dECL/dom1
26899        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
26900        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
26901         * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
26902        dGCLdOM1 = c1 - c2
26903 !c! dECL/dom2
26904        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
26905        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
26906         * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
26907        dGCLdOM2 = c1 - c2
26908 !c! dECL/dom12
26909        c1 = w1 / (Rhead ** 3.0d0)
26910        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
26911        dGCLdOM12 = c1 - c2
26912 !c!-------------------------------------------------------------------
26913 !c! Return the results
26914 !c! (see comments in Eqq)
26915        DO k= 1, 3
26916       erhead(k) = Rhead_distance(k)/Rhead
26917        END DO
26918        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26919        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26920        facd1 = d1 * vbld_inv(i+nres)
26921        facd2 = d2 * vbld_inv(j+nres)
26922        DO k = 1, 3
26923
26924       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26925       gvdwx(k,i) = gvdwx(k,i)    - dGCLdR * pom
26926       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26927       gvdwx(k,j) = gvdwx(k,j)    + dGCLdR * pom
26928
26929       gvdwc(k,i) = gvdwc(k,i)    - dGCLdR * erhead(k)
26930       gvdwc(k,j) = gvdwc(k,j)    + dGCLdR * erhead(k)
26931        END DO
26932        RETURN
26933       END SUBROUTINE edd
26934       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
26935 !       IMPLICIT NONE
26936        use comm_momo
26937       use calc_data
26938
26939        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
26940        eps_out=80.0d0
26941        itypi = itype(i,1)
26942        itypj = itype(j,1)
26943 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
26944 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
26945 !c!       t_bath = 300
26946 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
26947        Rb=0.001986d0
26948        BetaT = 1.0d0 / (298.0d0 * Rb)
26949 !c! Gay-berne var's
26950        sig0ij = sigma( itypi,itypj )
26951        chi1   = chi( itypi, itypj )
26952        chi2   = chi( itypj, itypi )
26953        chi12  = chi1 * chi2
26954        chip1  = chipp( itypi, itypj )
26955        chip2  = chipp( itypj, itypi )
26956        chip12 = chip1 * chip2
26957 !       chi1=0.0
26958 !       chi2=0.0
26959 !       chi12=0.0
26960 !       chip1=0.0
26961 !       chip2=0.0
26962 !       chip12=0.0
26963 !c! not used by momo potential, but needed by sc_angular which is shared
26964 !c! by all energy_potential subroutines
26965        alf1   = 0.0d0
26966        alf2   = 0.0d0
26967        alf12  = 0.0d0
26968 !c! location, location, location
26969 !       xj  = c( 1, nres+j ) - xi
26970 !       yj  = c( 2, nres+j ) - yi
26971 !       zj  = c( 3, nres+j ) - zi
26972        dxj = dc_norm( 1, nres+j )
26973        dyj = dc_norm( 2, nres+j )
26974        dzj = dc_norm( 3, nres+j )
26975 !c! distance from center of chain(?) to polar/charged head
26976 !c!       write (*,*) "istate = ", 1
26977 !c!       write (*,*) "ii = ", 1
26978 !c!       write (*,*) "jj = ", 1
26979        d1 = dhead(1, 1, itypi, itypj)
26980        d2 = dhead(2, 1, itypi, itypj)
26981 !c! ai*aj from Fgb
26982        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
26983 !c!       a12sq = a12sq * a12sq
26984 !c! charge of amino acid itypi is...
26985        Qi  = icharge(itypi)
26986        Qj  = icharge(itypj)
26987        Qij = Qi * Qj
26988 !c! chis1,2,12
26989        chis1 = chis(itypi,itypj)
26990        chis2 = chis(itypj,itypi)
26991        chis12 = chis1 * chis2
26992        sig1 = sigmap1(itypi,itypj)
26993        sig2 = sigmap2(itypi,itypj)
26994 !c!       write (*,*) "sig1 = ", sig1
26995 !c!       write (*,*) "sig2 = ", sig2
26996 !c! alpha factors from Fcav/Gcav
26997        b1cav = alphasur(1,itypi,itypj)
26998 !       b1cav=0.0
26999        b2cav = alphasur(2,itypi,itypj)
27000        b3cav = alphasur(3,itypi,itypj)
27001        b4cav = alphasur(4,itypi,itypj)
27002        wqd = wquad(itypi, itypj)
27003 !c! used by Fgb
27004        eps_in = epsintab(itypi,itypj)
27005        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
27006 !c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
27007 !c!-------------------------------------------------------------------
27008 !c! tail location and distance calculations
27009        Rtail = 0.0d0
27010        DO k = 1, 3
27011       ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
27012       ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
27013        END DO
27014 !c! tail distances will be themselves usefull elswhere
27015 !c1 (in Gcav, for example)
27016        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
27017        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
27018        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
27019        Rtail = dsqrt(  &
27020         (Rtail_distance(1)*Rtail_distance(1))  &
27021       + (Rtail_distance(2)*Rtail_distance(2))  &
27022       + (Rtail_distance(3)*Rtail_distance(3)))
27023 !c!-------------------------------------------------------------------
27024 !c! Calculate location and distance between polar heads
27025 !c! distance between heads
27026 !c! for each one of our three dimensional space...
27027        d1 = dhead(1, 1, itypi, itypj)
27028        d2 = dhead(2, 1, itypi, itypj)
27029
27030        DO k = 1,3
27031 !c! location of polar head is computed by taking hydrophobic centre
27032 !c! and moving by a d1 * dc_norm vector
27033 !c! see unres publications for very informative images
27034       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27035       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
27036 !c! distance
27037 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27038 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27039       Rhead_distance(k) = chead(k,2) - chead(k,1)
27040        END DO
27041 !c! pitagoras (root of sum of squares)
27042        Rhead = dsqrt(   &
27043         (Rhead_distance(1)*Rhead_distance(1)) &
27044       + (Rhead_distance(2)*Rhead_distance(2)) &
27045       + (Rhead_distance(3)*Rhead_distance(3)))
27046 !c!-------------------------------------------------------------------
27047 !c! zero everything that should be zero'ed
27048        Egb = 0.0d0
27049        ECL = 0.0d0
27050        Elj = 0.0d0
27051        Equad = 0.0d0
27052        Epol = 0.0d0
27053        eheadtail = 0.0d0
27054        dGCLdOM1 = 0.0d0
27055        dGCLdOM2 = 0.0d0
27056        dGCLdOM12 = 0.0d0
27057        dPOLdOM1 = 0.0d0
27058        dPOLdOM2 = 0.0d0
27059        RETURN
27060       END SUBROUTINE elgrad_init
27061
27062
27063       SUBROUTINE elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27064       use comm_momo
27065       use calc_data
27066        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
27067        eps_out=80.0d0
27068        itypi = itype(i,1)
27069        itypj = itype(j,5)
27070 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
27071 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
27072 !c!       t_bath = 300
27073 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
27074        Rb=0.001986d0
27075        BetaT = 1.0d0 / (298.0d0 * Rb)
27076 !c! Gay-berne var's
27077        sig0ij = sigmacat( itypi,itypj )
27078        chi1   = chi1cat( itypi, itypj )
27079        chi2   = 0.0d0
27080        chi12  = 0.0d0
27081        chip1  = chipp1cat( itypi, itypj )
27082        chip2  = 0.0d0
27083        chip12 = 0.0d0
27084 !c! not used by momo potential, but needed by sc_angular which is shared
27085 !c! by all energy_potential subroutines
27086        alf1   = 0.0d0
27087        alf2   = 0.0d0
27088        alf12  = 0.0d0
27089        dxj = dc_norm( 1, nres+j )
27090        dyj = dc_norm( 2, nres+j )
27091        dzj = dc_norm( 3, nres+j )
27092 !c! distance from center of chain(?) to polar/charged head
27093        d1 = dheadcat(1, 1, itypi, itypj)
27094        d2 = dheadcat(2, 1, itypi, itypj)
27095 !c! ai*aj from Fgb
27096        a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj)
27097 !c!       a12sq = a12sq * a12sq
27098 !c! charge of amino acid itypi is...
27099        Qi  = icharge(itypi)
27100        Qj  = ichargecat(itypj)
27101        Qij = Qi * Qj
27102 !c! chis1,2,12
27103        chis1 = chis1cat(itypi,itypj)
27104        chis2 = 0.0d0
27105        chis12 = 0.0d0
27106        sig1 = sigmap1cat(itypi,itypj)
27107        sig2 = sigmap2cat(itypi,itypj)
27108 !c! alpha factors from Fcav/Gcav
27109        b1cav = alphasurcat(1,itypi,itypj)
27110        b2cav = alphasurcat(2,itypi,itypj)
27111        b3cav = alphasurcat(3,itypi,itypj)
27112        b4cav = alphasurcat(4,itypi,itypj)
27113        wqd = wquadcat(itypi, itypj)
27114 !c! used by Fgb
27115        eps_in = epsintabcat(itypi,itypj)
27116        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
27117 !c!-------------------------------------------------------------------
27118 !c! tail location and distance calculations
27119        Rtail = 0.0d0
27120        DO k = 1, 3
27121       ctail(k,1)=c(k,i+nres)-dtailcat(1,itypi,itypj)*dc_norm(k,nres+i)
27122       ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
27123        END DO
27124 !c! tail distances will be themselves usefull elswhere
27125 !c1 (in Gcav, for example)
27126        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
27127        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
27128        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
27129        Rtail = dsqrt(  &
27130         (Rtail_distance(1)*Rtail_distance(1))  &
27131       + (Rtail_distance(2)*Rtail_distance(2))  &
27132       + (Rtail_distance(3)*Rtail_distance(3)))
27133 !c!-------------------------------------------------------------------
27134 !c! Calculate location and distance between polar heads
27135 !c! distance between heads
27136 !c! for each one of our three dimensional space...
27137        d1 = dheadcat(1, 1, itypi, itypj)
27138        d2 = dheadcat(2, 1, itypi, itypj)
27139
27140        DO k = 1,3
27141 !c! location of polar head is computed by taking hydrophobic centre
27142 !c! and moving by a d1 * dc_norm vector
27143 !c! see unres publications for very informative images
27144       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27145       chead(k,2) = c(k, j)
27146 !c! distance
27147 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27148 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27149       Rhead_distance(k) = chead(k,2) - chead(k,1)
27150        END DO
27151 !c! pitagoras (root of sum of squares)
27152        Rhead = dsqrt(   &
27153         (Rhead_distance(1)*Rhead_distance(1)) &
27154       + (Rhead_distance(2)*Rhead_distance(2)) &
27155       + (Rhead_distance(3)*Rhead_distance(3)))
27156 !c!-------------------------------------------------------------------
27157 !c! zero everything that should be zero'ed
27158        Egb = 0.0d0
27159        ECL = 0.0d0
27160        Elj = 0.0d0
27161        Equad = 0.0d0
27162        Epol = 0.0d0
27163        eheadtail = 0.0d0
27164        dGCLdOM1 = 0.0d0
27165        dGCLdOM2 = 0.0d0
27166        dGCLdOM12 = 0.0d0
27167        dPOLdOM1 = 0.0d0
27168        dPOLdOM2 = 0.0d0
27169        RETURN
27170       END SUBROUTINE elgrad_init_cat
27171
27172       SUBROUTINE elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27173       use comm_momo
27174       use calc_data
27175        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
27176        eps_out=80.0d0
27177        itypi = 10
27178        itypj = itype(j,5)
27179 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
27180 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
27181 !c!       t_bath = 300
27182 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
27183        Rb=0.001986d0
27184        BetaT = 1.0d0 / (298.0d0 * Rb)
27185 !c! Gay-berne var's
27186        sig0ij = sigmacat( itypi,itypj )
27187        chi1   = chi1cat( itypi, itypj )
27188        chi2   = 0.0d0
27189        chi12  = 0.0d0
27190        chip1  = chipp1cat( itypi, itypj )
27191        chip2  = 0.0d0
27192        chip12 = 0.0d0
27193 !c! not used by momo potential, but needed by sc_angular which is shared
27194 !c! by all energy_potential subroutines
27195        alf1   = 0.0d0
27196        alf2   = 0.0d0
27197        alf12  = 0.0d0
27198        dxj = 0.0d0 !dc_norm( 1, nres+j )
27199        dyj = 0.0d0 !dc_norm( 2, nres+j )
27200        dzj = 0.0d0 !dc_norm( 3, nres+j )
27201 !c! distance from center of chain(?) to polar/charged head
27202        d1 = dheadcat(1, 1, itypi, itypj)
27203        d2 = dheadcat(2, 1, itypi, itypj)
27204 !c! ai*aj from Fgb
27205        a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj)
27206 !c!       a12sq = a12sq * a12sq
27207 !c! charge of amino acid itypi is...
27208        Qi  = 0
27209        Qj  = ichargecat(itypj)
27210 !       Qij = Qi * Qj
27211 !c! chis1,2,12
27212        chis1 = chis1cat(itypi,itypj)
27213        chis2 = 0.0d0
27214        chis12 = 0.0d0
27215        sig1 = sigmap1cat(itypi,itypj)
27216        sig2 = sigmap2cat(itypi,itypj)
27217 !c! alpha factors from Fcav/Gcav
27218        b1cav = alphasurcat(1,itypi,itypj)
27219        b2cav = alphasurcat(2,itypi,itypj)
27220        b3cav = alphasurcat(3,itypi,itypj)
27221        b4cav = alphasurcat(4,itypi,itypj)
27222        wqd = wquadcat(itypi, itypj)
27223 !c! used by Fgb
27224        eps_in = epsintabcat(itypi,itypj)
27225        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
27226 !c!-------------------------------------------------------------------
27227 !c! tail location and distance calculations
27228        Rtail = 0.0d0
27229        DO k = 1, 3
27230       ctail(k,1)=(c(k,i)+c(k,i+1))/2.0-dtailcat(1,itypi,itypj)*dc_norm(k,i)
27231       ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
27232        END DO
27233 !c! tail distances will be themselves usefull elswhere
27234 !c1 (in Gcav, for example)
27235        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
27236        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
27237        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
27238        Rtail = dsqrt(  &
27239         (Rtail_distance(1)*Rtail_distance(1))  &
27240       + (Rtail_distance(2)*Rtail_distance(2))  &
27241       + (Rtail_distance(3)*Rtail_distance(3)))
27242 !c!-------------------------------------------------------------------
27243 !c! Calculate location and distance between polar heads
27244 !c! distance between heads
27245 !c! for each one of our three dimensional space...
27246        d1 = dheadcat(1, 1, itypi, itypj)
27247        d2 = dheadcat(2, 1, itypi, itypj)
27248
27249        DO k = 1,3
27250 !c! location of polar head is computed by taking hydrophobic centre
27251 !c! and moving by a d1 * dc_norm vector
27252 !c! see unres publications for very informative images
27253       chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
27254       chead(k,2) = c(k, j)
27255 !c! distance
27256 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27257 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27258       Rhead_distance(k) = chead(k,2) - chead(k,1)
27259        END DO
27260 !c! pitagoras (root of sum of squares)
27261        Rhead = dsqrt(   &
27262         (Rhead_distance(1)*Rhead_distance(1)) &
27263       + (Rhead_distance(2)*Rhead_distance(2)) &
27264       + (Rhead_distance(3)*Rhead_distance(3)))
27265 !c!-------------------------------------------------------------------
27266 !c! zero everything that should be zero'ed
27267        Egb = 0.0d0
27268        ECL = 0.0d0
27269        Elj = 0.0d0
27270        Equad = 0.0d0
27271        Epol = 0.0d0
27272        eheadtail = 0.0d0
27273        dGCLdOM1 = 0.0d0
27274        dGCLdOM2 = 0.0d0
27275        dGCLdOM12 = 0.0d0
27276        dPOLdOM1 = 0.0d0
27277        dPOLdOM2 = 0.0d0
27278        RETURN
27279       END SUBROUTINE elgrad_init_cat_pep
27280
27281       double precision function tschebyshev(m,n,x,y)
27282       implicit none
27283       integer i,m,n
27284       double precision x(n),y,yy(0:maxvar),aux
27285 !c Tschebyshev polynomial. Note that the first term is omitted
27286 !c m=0: the constant term is included
27287 !c m=1: the constant term is not included
27288       yy(0)=1.0d0
27289       yy(1)=y
27290       do i=2,n
27291       yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
27292       enddo
27293       aux=0.0d0
27294       do i=m,n
27295       aux=aux+x(i)*yy(i)
27296       enddo
27297       tschebyshev=aux
27298       return
27299       end function tschebyshev
27300 !C--------------------------------------------------------------------------
27301       double precision function gradtschebyshev(m,n,x,y)
27302       implicit none
27303       integer i,m,n
27304       double precision x(n+1),y,yy(0:maxvar),aux
27305 !c Tschebyshev polynomial. Note that the first term is omitted
27306 !c m=0: the constant term is included
27307 !c m=1: the constant term is not included
27308       yy(0)=1.0d0
27309       yy(1)=2.0d0*y
27310       do i=2,n
27311       yy(i)=2*y*yy(i-1)-yy(i-2)
27312       enddo
27313       aux=0.0d0
27314       do i=m,n
27315       aux=aux+x(i+1)*yy(i)*(i+1)
27316 !C        print *, x(i+1),yy(i),i
27317       enddo
27318       gradtschebyshev=aux
27319       return
27320       end function gradtschebyshev
27321
27322       subroutine make_SCSC_inter_list
27323       include 'mpif.h'
27324       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
27325       real*8 :: dist_init, dist_temp,r_buff_list
27326       integer:: contlisti(250*nres),contlistj(250*nres)
27327 !      integer :: newcontlisti(200*nres),newcontlistj(200*nres)
27328       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_sc,g_ilist_sc
27329       integer displ(0:nprocs),i_ilist_sc(0:nprocs),ierr
27330 !            print *,"START make_SC"
27331         r_buff_list=5.0
27332           ilist_sc=0
27333           do i=iatsc_s,iatsc_e
27334            itypi=iabs(itype(i,1))
27335            if (itypi.eq.ntyp1) cycle
27336            xi=c(1,nres+i)
27337            yi=c(2,nres+i)
27338            zi=c(3,nres+i)
27339           call to_box(xi,yi,zi)
27340            do iint=1,nint_gr(i)
27341             do j=istart(i,iint),iend(i,iint)
27342              itypj=iabs(itype(j,1))
27343              if (itypj.eq.ntyp1) cycle
27344              xj=c(1,nres+j)
27345              yj=c(2,nres+j)
27346              zj=c(3,nres+j)
27347              call to_box(xj,yj,zj)
27348              dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
27349 ! r_buff_list is a read value for a buffer
27350              if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
27351 ! Here the list is created
27352              ilist_sc=ilist_sc+1
27353 ! this can be substituted by cantor and anti-cantor
27354              contlisti(ilist_sc)=i
27355              contlistj(ilist_sc)=j
27356
27357              endif
27358            enddo
27359            enddo
27360            enddo
27361 !         call MPI_Reduce(ilist_sc,g_ilist_sc,1,&
27362 !          MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
27363 !        call MPI_Gather(newnss,1,MPI_INTEGER,&
27364 !                        i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
27365 #ifdef DEBUG
27366       write (iout,*) "before MPIREDUCE",ilist_sc
27367       do i=1,ilist_sc
27368       write (iout,*) i,contlisti(i),contlistj(i)
27369       enddo
27370 #endif
27371       if (nfgtasks.gt.1)then
27372
27373       call MPI_Reduce(ilist_sc,g_ilist_sc,1,&
27374         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
27375 !        write(iout,*) "before bcast",g_ilist_sc
27376       call MPI_Gather(ilist_sc,1,MPI_INTEGER,&
27377                   i_ilist_sc,1,MPI_INTEGER,king,FG_COMM,IERR)
27378       displ(0)=0
27379       do i=1,nfgtasks-1,1
27380         displ(i)=i_ilist_sc(i-1)+displ(i-1)
27381       enddo
27382 !        write(iout,*) "before gather",displ(0),displ(1)
27383       call MPI_Gatherv(contlisti,ilist_sc,MPI_INTEGER,&
27384                    newcontlisti,i_ilist_sc,displ,MPI_INTEGER,&
27385                    king,FG_COMM,IERR)
27386       call MPI_Gatherv(contlistj,ilist_sc,MPI_INTEGER,&
27387                    newcontlistj,i_ilist_sc,displ,MPI_INTEGER,&
27388                    king,FG_COMM,IERR)
27389       call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM,IERR)
27390 !        write(iout,*) "before bcast",g_ilist_sc
27391 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27392       call MPI_Bcast(newcontlisti,g_ilist_sc,MPI_INT,king,FG_COMM,IERR)
27393       call MPI_Bcast(newcontlistj,g_ilist_sc,MPI_INT,king,FG_COMM,IERR)
27394
27395 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27396
27397       else
27398       g_ilist_sc=ilist_sc
27399
27400       do i=1,ilist_sc
27401       newcontlisti(i)=contlisti(i)
27402       newcontlistj(i)=contlistj(i)
27403       enddo
27404       endif
27405
27406 #ifdef DEBUG
27407       write (iout,*) "after MPIREDUCE",g_ilist_sc
27408       do i=1,g_ilist_sc
27409       write (iout,*) i,newcontlisti(i),newcontlistj(i)
27410       enddo
27411 #endif
27412       call int_bounds(g_ilist_sc,g_listscsc_start,g_listscsc_end)
27413       return
27414       end subroutine make_SCSC_inter_list
27415 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
27416
27417       subroutine make_SCp_inter_list
27418       use MD_data,  only: itime_mat
27419
27420       include 'mpif.h'
27421       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
27422       real*8 :: dist_init, dist_temp,r_buff_list
27423       integer:: contlistscpi(250*nres),contlistscpj(250*nres)
27424 !      integer :: newcontlistscpi(200*nres),newcontlistscpj(200*nres)
27425       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_scp,g_ilist_scp
27426       integer displ(0:nprocs),i_ilist_scp(0:nprocs),ierr
27427 !            print *,"START make_SC"
27428       r_buff_list=5.0
27429           ilist_scp=0
27430       do i=iatscp_s,iatscp_e
27431       if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
27432       xi=0.5D0*(c(1,i)+c(1,i+1))
27433       yi=0.5D0*(c(2,i)+c(2,i+1))
27434       zi=0.5D0*(c(3,i)+c(3,i+1))
27435         call to_box(xi,yi,zi)
27436       do iint=1,nscp_gr(i)
27437
27438       do j=iscpstart(i,iint),iscpend(i,iint)
27439         itypj=iabs(itype(j,1))
27440         if (itypj.eq.ntyp1) cycle
27441 ! Uncomment following three lines for SC-p interactions
27442 !         xj=c(1,nres+j)-xi
27443 !         yj=c(2,nres+j)-yi
27444 !         zj=c(3,nres+j)-zi
27445 ! Uncomment following three lines for Ca-p interactions
27446 !          xj=c(1,j)-xi
27447 !          yj=c(2,j)-yi
27448 !          zj=c(3,j)-zi
27449         xj=c(1,j)
27450         yj=c(2,j)
27451         zj=c(3,j)
27452         call to_box(xj,yj,zj)
27453       xj=boxshift(xj-xi,boxxsize)
27454       yj=boxshift(yj-yi,boxysize)
27455       zj=boxshift(zj-zi,boxzsize)
27456       dist_init=xj**2+yj**2+zj**2
27457 #ifdef DEBUG
27458             ! r_buff_list is a read value for a buffer
27459              if ((sqrt(dist_init).le.(r_cut_ele)).and.(ifirstrun.eq.0)) then
27460 ! Here the list is created
27461              ilist_scp_first=ilist_scp_first+1
27462 ! this can be substituted by cantor and anti-cantor
27463              contlistscpi_f(ilist_scp_first)=i
27464              contlistscpj_f(ilist_scp_first)=j
27465             endif
27466 #endif
27467 ! r_buff_list is a read value for a buffer
27468              if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
27469 ! Here the list is created
27470              ilist_scp=ilist_scp+1
27471 ! this can be substituted by cantor and anti-cantor
27472              contlistscpi(ilist_scp)=i
27473              contlistscpj(ilist_scp)=j
27474             endif
27475            enddo
27476            enddo
27477            enddo
27478 #ifdef DEBUG
27479       write (iout,*) "before MPIREDUCE",ilist_scp
27480       do i=1,ilist_scp
27481       write (iout,*) i,contlistscpi(i),contlistscpj(i)
27482       enddo
27483 #endif
27484       if (nfgtasks.gt.1)then
27485
27486       call MPI_Reduce(ilist_scp,g_ilist_scp,1,&
27487         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
27488 !        write(iout,*) "before bcast",g_ilist_sc
27489       call MPI_Gather(ilist_scp,1,MPI_INTEGER,&
27490                   i_ilist_scp,1,MPI_INTEGER,king,FG_COMM,IERR)
27491       displ(0)=0
27492       do i=1,nfgtasks-1,1
27493         displ(i)=i_ilist_scp(i-1)+displ(i-1)
27494       enddo
27495 !        write(iout,*) "before gather",displ(0),displ(1)
27496       call MPI_Gatherv(contlistscpi,ilist_scp,MPI_INTEGER,&
27497                    newcontlistscpi,i_ilist_scp,displ,MPI_INTEGER,&
27498                    king,FG_COMM,IERR)
27499       call MPI_Gatherv(contlistscpj,ilist_scp,MPI_INTEGER,&
27500                    newcontlistscpj,i_ilist_scp,displ,MPI_INTEGER,&
27501                    king,FG_COMM,IERR)
27502       call MPI_Bcast(g_ilist_scp,1,MPI_INT,king,FG_COMM,IERR)
27503 !        write(iout,*) "before bcast",g_ilist_sc
27504 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27505       call MPI_Bcast(newcontlistscpi,g_ilist_scp,MPI_INT,king,FG_COMM,IERR)
27506       call MPI_Bcast(newcontlistscpj,g_ilist_scp,MPI_INT,king,FG_COMM,IERR)
27507
27508 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27509
27510       else
27511       g_ilist_scp=ilist_scp
27512
27513       do i=1,ilist_scp
27514       newcontlistscpi(i)=contlistscpi(i)
27515       newcontlistscpj(i)=contlistscpj(i)
27516       enddo
27517       endif
27518
27519 #ifdef DEBUG
27520       write (iout,*) "after MPIREDUCE",g_ilist_scp
27521       do i=1,g_ilist_scp
27522       write (iout,*) i,newcontlistscpi(i),newcontlistscpj(i)
27523       enddo
27524
27525 !      if (ifirstrun.eq.0) ifirstrun=1
27526 !      do i=1,ilist_scp_first
27527 !       do j=1,g_ilist_scp
27528 !        if ((newcontlistscpi(j).eq.contlistscpi_f(i)).and.&
27529 !         (newcontlistscpj(j).eq.contlistscpj_f(i))) go to 126
27530 !        enddo
27531 !       print *,itime_mat,"ERROR matrix needs updating"
27532 !       print *,contlistscpi_f(i),contlistscpj_f(i)
27533 !  126  continue
27534 !      enddo
27535 #endif
27536       call int_bounds(g_ilist_scp,g_listscp_start,g_listscp_end)
27537
27538       return
27539       end subroutine make_SCp_inter_list
27540
27541 !-----------------------------------------------------------------------------
27542 !-----------------------------------------------------------------------------
27543
27544
27545       subroutine make_pp_inter_list
27546       include 'mpif.h'
27547       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
27548       real*8 :: xmedj,ymedj,zmedj,sslipi,ssgradlipi,faclipij2,sslipj,ssgradlipj
27549       real*8 :: dist_init, dist_temp,r_buff_list,dxi,dyi,dzi,xmedi,ymedi,zmedi
27550       real*8 :: dx_normi,dy_normi,dz_normi,dxj,dyj,dzj,dx_normj,dy_normj,dz_normj
27551       integer:: contlistppi(250*nres),contlistppj(250*nres)
27552 !      integer :: newcontlistppi(200*nres),newcontlistppj(200*nres)
27553       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_pp,g_ilist_pp
27554       integer displ(0:nprocs),i_ilist_pp(0:nprocs),ierr
27555             write(iout,*),"START make_pp",iatel_s,iatel_e,r_cut_ele+r_buff_list
27556             ilist_pp=0
27557       r_buff_list=5.0
27558       do i=iatel_s,iatel_e
27559         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
27560         dxi=dc(1,i)
27561         dyi=dc(2,i)
27562         dzi=dc(3,i)
27563         dx_normi=dc_norm(1,i)
27564         dy_normi=dc_norm(2,i)
27565         dz_normi=dc_norm(3,i)
27566         xmedi=c(1,i)+0.5d0*dxi
27567         ymedi=c(2,i)+0.5d0*dyi
27568         zmedi=c(3,i)+0.5d0*dzi
27569
27570         call to_box(xmedi,ymedi,zmedi)
27571         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
27572 !          write (iout,*) i,j,itype(i,1),itype(j,1)
27573 !          if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
27574
27575 ! 1,j)
27576              do j=ielstart(i),ielend(i)
27577 !          write (iout,*) i,j,itype(i,1),itype(j,1)
27578           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
27579           dxj=dc(1,j)
27580           dyj=dc(2,j)
27581           dzj=dc(3,j)
27582           dx_normj=dc_norm(1,j)
27583           dy_normj=dc_norm(2,j)
27584           dz_normj=dc_norm(3,j)
27585 !          xj=c(1,j)+0.5D0*dxj-xmedi
27586 !          yj=c(2,j)+0.5D0*dyj-ymedi
27587 !          zj=c(3,j)+0.5D0*dzj-zmedi
27588           xj=c(1,j)+0.5D0*dxj
27589           yj=c(2,j)+0.5D0*dyj
27590           zj=c(3,j)+0.5D0*dzj
27591           call to_box(xj,yj,zj)
27592 !          call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
27593 !          faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
27594           xj=boxshift(xj-xmedi,boxxsize)
27595           yj=boxshift(yj-ymedi,boxysize)
27596           zj=boxshift(zj-zmedi,boxzsize)
27597           dist_init=xj**2+yj**2+zj**2
27598       if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
27599 ! Here the list is created
27600                  ilist_pp=ilist_pp+1
27601 ! this can be substituted by cantor and anti-cantor
27602                  contlistppi(ilist_pp)=i
27603                  contlistppj(ilist_pp)=j
27604               endif
27605 !             enddo
27606              enddo
27607              enddo
27608 #ifdef DEBUG
27609       write (iout,*) "before MPIREDUCE",ilist_pp
27610       do i=1,ilist_pp
27611       write (iout,*) i,contlistppi(i),contlistppj(i)
27612       enddo
27613 #endif
27614       if (nfgtasks.gt.1)then
27615
27616         call MPI_Reduce(ilist_pp,g_ilist_pp,1,&
27617           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
27618 !        write(iout,*) "before bcast",g_ilist_sc
27619         call MPI_Gather(ilist_pp,1,MPI_INTEGER,&
27620                         i_ilist_pp,1,MPI_INTEGER,king,FG_COMM,IERR)
27621         displ(0)=0
27622         do i=1,nfgtasks-1,1
27623           displ(i)=i_ilist_pp(i-1)+displ(i-1)
27624         enddo
27625 !        write(iout,*) "before gather",displ(0),displ(1)
27626         call MPI_Gatherv(contlistppi,ilist_pp,MPI_INTEGER,&
27627                          newcontlistppi,i_ilist_pp,displ,MPI_INTEGER,&
27628                          king,FG_COMM,IERR)
27629         call MPI_Gatherv(contlistppj,ilist_pp,MPI_INTEGER,&
27630                          newcontlistppj,i_ilist_pp,displ,MPI_INTEGER,&
27631                          king,FG_COMM,IERR)
27632         call MPI_Bcast(g_ilist_pp,1,MPI_INT,king,FG_COMM,IERR)
27633 !        write(iout,*) "before bcast",g_ilist_sc
27634 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27635         call MPI_Bcast(newcontlistppi,g_ilist_pp,MPI_INT,king,FG_COMM,IERR)
27636         call MPI_Bcast(newcontlistppj,g_ilist_pp,MPI_INT,king,FG_COMM,IERR)
27637
27638 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27639
27640         else
27641         g_ilist_pp=ilist_pp
27642
27643         do i=1,ilist_pp
27644         newcontlistppi(i)=contlistppi(i)
27645         newcontlistppj(i)=contlistppj(i)
27646         enddo
27647         endif
27648         call int_bounds(g_ilist_pp,g_listpp_start,g_listpp_end)
27649 #ifdef DEBUG
27650       write (iout,*) "after MPIREDUCE",g_ilist_pp
27651       do i=1,g_ilist_pp
27652       write (iout,*) i,newcontlistppi(i),newcontlistppj(i)
27653       enddo
27654 #endif
27655       return
27656       end subroutine make_pp_inter_list
27657
27658 !-----------------------------------------------------------------------------
27659       double precision function boxshift(x,boxsize)
27660       implicit none
27661       double precision x,boxsize
27662       double precision xtemp
27663       xtemp=dmod(x,boxsize)
27664       if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
27665         boxshift=xtemp-boxsize
27666       else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
27667         boxshift=xtemp+boxsize
27668       else
27669         boxshift=xtemp
27670       endif
27671       return
27672       end function boxshift
27673 !-----------------------------------------------------------------------------
27674       subroutine to_box(xi,yi,zi)
27675       implicit none
27676 !      include 'DIMENSIONS'
27677 !      include 'COMMON.CHAIN'
27678       double precision xi,yi,zi
27679       xi=dmod(xi,boxxsize)
27680       if (xi.lt.0.0d0) xi=xi+boxxsize
27681       yi=dmod(yi,boxysize)
27682       if (yi.lt.0.0d0) yi=yi+boxysize
27683       zi=dmod(zi,boxzsize)
27684       if (zi.lt.0.0d0) zi=zi+boxzsize
27685       return
27686       end subroutine to_box
27687 !--------------------------------------------------------------------------
27688       subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
27689       implicit none
27690 !      include 'DIMENSIONS'
27691 !      include 'COMMON.IOUNITS'
27692 !      include 'COMMON.CHAIN'
27693       double precision xi,yi,zi,sslipi,ssgradlipi
27694       double precision fracinbuf
27695 !      double precision sscalelip,sscagradlip
27696 #ifdef DEBUG
27697       write (iout,*) "bordlipbot",bordlipbot," bordliptop",bordliptop
27698       write (iout,*) "buflipbot",buflipbot," lipbufthick",lipbufthick
27699       write (iout,*) "xi yi zi",xi,yi,zi
27700 #endif
27701       if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
27702 ! the energy transfer exist
27703         if (zi.lt.buflipbot) then
27704 ! what fraction I am in
27705           fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
27706 ! lipbufthick is thickenes of lipid buffore
27707           sslipi=sscalelip(fracinbuf)
27708           ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
27709         elseif (zi.gt.bufliptop) then
27710           fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
27711           sslipi=sscalelip(fracinbuf)
27712           ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
27713         else
27714           sslipi=1.0d0
27715           ssgradlipi=0.0
27716         endif
27717       else
27718         sslipi=0.0d0
27719         ssgradlipi=0.0
27720       endif
27721 #ifdef DEBUG
27722       write (iout,*) "sslipi",sslipi," ssgradlipi",ssgradlipi
27723 #endif
27724       return
27725       end subroutine lipid_layer
27726
27727 !--------------------------------------------------------------------------
27728 !--------------------------------------------------------------------------
27729       end module energy