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,gradnuclcat,gradnuclcatx
 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                       ecation_nucl
 252 ! energies for protein nucleic acid interaction
 253       real(kind=8) :: escbase,epepbase,escpho,epeppho
 254
 255 #ifdef MPI
 256       real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw
 257 ! shielding effect varibles for MPI
 258       real(kind=8) ::  fac_shieldbuf(nres), &
 259       grad_shield_locbuf1(3*maxcontsshi*nres), &
 260       grad_shield_sidebuf1(3*maxcontsshi*nres), &
 261       grad_shield_locbuf2(3*maxcontsshi*nres), &
 262       grad_shield_sidebuf2(3*maxcontsshi*nres), &
 263       grad_shieldbuf1(3*nres), &
 264       grad_shieldbuf2(3*nres)
 265
 266        integer ishield_listbuf(-1:nres), &
 267        shield_listbuf(maxcontsshi,-1:nres),k,j,i,iii,impishi,mojint,jjj
 268 !       print *,"I START ENERGY"
 269        imatupdate=100
 270 !       if (mod(itime_mat,imatupdate).eq.0) call make_SCSC_inter_list
 271 !      real(kind=8),  dimension(:),allocatable::  fac_shieldbuf
 272 !      real(kind=8), dimension(:,:,:),allocatable:: &
 273 !       grad_shield_locbuf,grad_shield_sidebuf
 274 !      real(kind=8), dimension(:,:),allocatable:: &
 275 !        grad_shieldbuf
 276 !       integer, dimension(:),allocatable:: &
 277 !       ishield_listbuf
 278 !       integer, dimension(:,:),allocatable::  shield_listbuf
 279 !       integer :: k,j,i
 280 !      if (.not.allocated(fac_shieldbuf)) then
 281 !          allocate(fac_shieldbuf(nres))
 282 !          allocate(grad_shield_locbuf(3,maxcontsshi,-1:nres))
 283 !          allocate(grad_shield_sidebuf(3,maxcontsshi,-1:nres))
 284 !          allocate(grad_shieldbuf(3,-1:nres))
 285 !          allocate(ishield_listbuf(nres))
 286 !          allocate(shield_listbuf(maxcontsshi,nres))
 287 !       endif
 288
 289 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 290 !     & " nfgtasks",nfgtasks
 291       if (nfgtasks.gt.1) then
 292         time00=MPI_Wtime()
 293 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 294         if (fg_rank.eq.0) then
 295           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 296 !          print *,"Processor",myrank," BROADCAST iorder"
 297 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 298 ! FG slaves as WEIGHTS array.
 299           weights_(1)=wsc
 300           weights_(2)=wscp
 301           weights_(3)=welec
 302           weights_(4)=wcorr
 303           weights_(5)=wcorr5
 304           weights_(6)=wcorr6
 305           weights_(7)=wel_loc
 306           weights_(8)=wturn3
 307           weights_(9)=wturn4
 308           weights_(10)=wturn6
 309           weights_(11)=wang
 310           weights_(12)=wscloc
 311           weights_(13)=wtor
 312           weights_(14)=wtor_d
 313           weights_(15)=wstrain
 314           weights_(16)=wvdwpp
 315           weights_(17)=wbond
 316           weights_(18)=scal14
 317           weights_(21)=wsccor
 318           weights_(26)=wvdwpp_nucl
 319           weights_(27)=welpp
 320           weights_(28)=wvdwpsb
 321           weights_(29)=welpsb
 322           weights_(30)=wvdwsb
 323           weights_(31)=welsb
 324           weights_(32)=wbond_nucl
 325           weights_(33)=wang_nucl
 326           weights_(34)=wsbloc
 327           weights_(35)=wtor_nucl
 328           weights_(36)=wtor_d_nucl
 329           weights_(37)=wcorr_nucl
 330           weights_(38)=wcorr3_nucl
 331           weights_(41)=wcatcat
 332           weights_(42)=wcatprot
 333           weights_(46)=wscbase
 334           weights_(47)=wpepbase
 335           weights_(48)=wscpho
 336           weights_(49)=wpeppho
 337           weights_(50)=wcatnucl
 338 !          wcatcat= weights(41)
 339 !          wcatprot=weights(42)
 340
 341 ! FG Master broadcasts the WEIGHTS_ array
 342           call MPI_Bcast(weights_(1),n_ene,&
 343              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 344         else
 345 ! FG slaves receive the WEIGHTS array
 346           call MPI_Bcast(weights(1),n_ene,&
 347               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 348           wsc=weights(1)
 349           wscp=weights(2)
 350           welec=weights(3)
 351           wcorr=weights(4)
 352           wcorr5=weights(5)
 353           wcorr6=weights(6)
 354           wel_loc=weights(7)
 355           wturn3=weights(8)
 356           wturn4=weights(9)
 357           wturn6=weights(10)
 358           wang=weights(11)
 359           wscloc=weights(12)
 360           wtor=weights(13)
 361           wtor_d=weights(14)
 362           wstrain=weights(15)
 363           wvdwpp=weights(16)
 364           wbond=weights(17)
 365           scal14=weights(18)
 366           wsccor=weights(21)
 367           wvdwpp_nucl =weights(26)
 368           welpp  =weights(27)
 369           wvdwpsb=weights(28)
 370           welpsb =weights(29)
 371           wvdwsb =weights(30)
 372           welsb  =weights(31)
 373           wbond_nucl  =weights(32)
 374           wang_nucl   =weights(33)
 375           wsbloc =weights(34)
 376           wtor_nucl   =weights(35)
 377           wtor_d_nucl =weights(36)
 378           wcorr_nucl  =weights(37)
 379           wcorr3_nucl =weights(38)
 380           wcatcat= weights(41)
 381           wcatprot=weights(42)
 382           wscbase=weights(46)
 383           wpepbase=weights(47)
 384           wscpho=weights(48)
 385           wpeppho=weights(49)
 386           wcatnucl=weights(50)
 387 !      welpsb=weights(28)*fact(1)
 388 !
 389 !      wcorr_nucl= weights(37)*fact(1)
 390 !     wcorr3_nucl=weights(38)*fact(2)
 391 !     wtor_nucl=  weights(35)*fact(1)
 392 !     wtor_d_nucl=weights(36)*fact(2)
 393
 394         endif
 395         time_Bcast=time_Bcast+MPI_Wtime()-time00
 396         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 397 !        call chainbuild_cart
 398       endif
 399 !       print *,"itime_mat",itime_mat,imatupdate
 400         if (nfgtasks.gt.1) then
 401         call MPI_Bcast(itime_mat,1,MPI_INT,king,FG_COMM,IERROR)
 402         endif
 403        if (mod(itime_mat,imatupdate).eq.0) call make_SCp_inter_list
 404 !       write (iout,*) "after make_SCp_inter_list"
 405        if (mod(itime_mat,imatupdate).eq.0) call make_SCSC_inter_list
 406 !       write (iout,*) "after make_SCSC_inter_list"
 407
 408        if (mod(itime_mat,imatupdate).eq.0) call make_pp_inter_list
 409 !       write (iout,*) "after make_pp_inter_list"
 410
 411 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 412 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 413 #else
 414 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 415 !        call int_from_cart1(.false.)
 416 !      endif
 417 #endif
 418 #ifdef TIMING
 419       time00=MPI_Wtime()
 420 #endif
 421 !
 422 ! Compute the side-chain and electrostatic interaction energy
 423 !        print *, "Before EVDW"
 424 !      goto (101,102,103,104,105,106) ipot
 425       select case(ipot)
 426 ! Lennard-Jones potential.
 427 !  101 call elj(evdw)
 428        case (1)
 429          call elj(evdw)
 430 !d    print '(a)','Exit ELJcall el'
 431 !      goto 107
 432 ! Lennard-Jones-Kihara potential (shifted).
 433 !  102 call eljk(evdw)
 434        case (2)
 435          call eljk(evdw)
 436 !      goto 107
 437 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 438 !  103 call ebp(evdw)
 439        case (3)
 440          call ebp(evdw)
 441 !      goto 107
 442 ! Gay-Berne potential (shifted LJ, angular dependence).
 443 !  104 call egb(evdw)
 444        case (4)
 445 !       print *,"MOMO",scelemode
 446         if (scelemode.eq.0) then
 447          call egb(evdw)
 448         else
 449          call emomo(evdw)
 450         endif
 451 !      goto 107
 452 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 453 !  105 call egbv(evdw)
 454        case (5)
 455          call egbv(evdw)
 456 !      goto 107
 457 ! Soft-sphere potential
 458 !  106 call e_softsphere(evdw)
 459        case (6)
 460          call e_softsphere(evdw)
 461 !
 462 ! Calculate electrostatic (H-bonding) energy of the main chain.
 463 !
 464 !  107 continue
 465        case default
 466          write(iout,*)"Wrong ipot"
 467 !         return
 468 !   50 continue
 469       end select
 470 !      continue
 471 !        print *,"after EGB"
 472 ! shielding effect
 473        if (shield_mode.eq.2) then
 474                  call set_shield_fac2
 475
 476       if (nfgtasks.gt.1) then
 477       grad_shield_sidebuf1(:)=0.0d0
 478       grad_shield_locbuf1(:)=0.0d0
 479       grad_shield_sidebuf2(:)=0.0d0
 480       grad_shield_locbuf2(:)=0.0d0
 481       grad_shieldbuf1(:)=0.0d0
 482       grad_shieldbuf2(:)=0.0d0
 483 !#define DEBUG
 484 #ifdef DEBUG
 485        write(iout,*) "befor reduce fac_shield reduce"
 486        do i=1,nres
 487         write(2,*) "fac",itype(i,1),fac_shield(i),grad_shield(1,i)
 488         write(2,*) "list", shield_list(1,i),ishield_list(i), &
 489        grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 490        enddo
 491 #endif
 492         iii=0
 493         jjj=0
 494         do i=1,nres
 495         ishield_listbuf(i)=0
 496         do k=1,3
 497         iii=iii+1
 498         grad_shieldbuf1(iii)=grad_shield(k,i)
 499         enddo
 500         enddo
 501         do i=1,nres
 502          do j=1,maxcontsshi
 503           do k=1,3
 504               jjj=jjj+1
 505               grad_shield_sidebuf1(jjj)=grad_shield_side(k,j,i)
 506               grad_shield_locbuf1(jjj)=grad_shield_loc(k,j,i)
 507            enddo
 508           enddo
 509          enddo
 510         call MPI_Allgatherv(fac_shield(ivec_start), &
 511         ivec_count(fg_rank1), &
 512         MPI_DOUBLE_PRECISION,fac_shieldbuf(1),ivec_count(0), &
 513         ivec_displ(0), &
 514         MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 515         call MPI_Allgatherv(shield_list(1,ivec_start), &
 516         ivec_count(fg_rank1), &
 517         MPI_I50,shield_listbuf(1,1),ivec_count(0), &
 518         ivec_displ(0), &
 519         MPI_I50,FG_COMM,IERROR)
 520 !        write(2,*) "After I50"
 521 !        call flush(iout)
 522         call MPI_Allgatherv(ishield_list(ivec_start), &
 523         ivec_count(fg_rank1), &
 524         MPI_INTEGER,ishield_listbuf(1),ivec_count(0), &
 525         ivec_displ(0), &
 526         MPI_INTEGER,FG_COMM,IERROR)
 527 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 528
 529 !        write(2,*) ivec_count(fg_rank1)*3,ivec_count(0)*3,ivec_displ(0)*3,3*ivec_start-2
 530 !        write (2,*) "before"
 531 !        write(2,*) grad_shieldbuf1
 532 !        call MPI_Allgatherv(grad_shieldbuf1(3*ivec_start-2), &
 533 !        ivec_count(fg_rank1)*3, &
 534 !        MPI_DOUBLE_PRECISION,grad_shieldbuf2(1),ivec_count(0), &
 535 !        ivec_count(0), &
 536 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 537         call MPI_Allreduce(grad_shieldbuf1(1),grad_shieldbuf2(1), &
 538         nres*3, &
 539         MPI_DOUBLE_PRECISION, &
 540         MPI_SUM, &
 541         FG_COMM,IERROR)
 542         call MPI_Allreduce(grad_shield_sidebuf1(1),grad_shield_sidebuf2(1), &
 543         nres*3*maxcontsshi, &
 544         MPI_DOUBLE_PRECISION, &
 545         MPI_SUM, &
 546         FG_COMM,IERROR)
 547
 548         call MPI_Allreduce(grad_shield_locbuf1(1),grad_shield_locbuf2(1), &
 549         nres*3*maxcontsshi, &
 550         MPI_DOUBLE_PRECISION, &
 551         MPI_SUM, &
 552         FG_COMM,IERROR)
 553
 554 !        write(2,*) "after"
 555 !        write(2,*) grad_shieldbuf2
 556
 557 !        call MPI_Allgatherv(grad_shield_sidebuf1(3*maxcontsshi*ivec_start-2), &
 558 !        ivec_count(fg_rank1)*3*maxcontsshi, &
 559 !        MPI_DOUBLE_PRECISION,grad_shield_sidebuf2(1),ivec_count(0)*3*maxcontsshi,&
 560 !        ivec_displ(0)*3*maxcontsshi, &
 561 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 562 !        write(2,*) "After grad_shield_side"
 563 !        call flush(iout)
 564 !        call MPI_Allgatherv(grad_shield_locbuf1(3*maxcontsshi*ivec_start-2), &
 565 !        ivec_count(fg_rank1)*3*maxcontsshi, &
 566 !        MPI_DOUBLE_PRECISION,grad_shield_locbuf2(1),ivec_count(0)*3*maxcontsshi, &
 567 !        ivec_displ(0)*3*maxcontsshi, &
 568 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 569 !        write(2,*) "After MPI_SHI"
 570 !        call flush(iout)
 571         iii=0
 572         jjj=0
 573         do i=1,nres
 574          fac_shield(i)=fac_shieldbuf(i)
 575          ishield_list(i)=ishield_listbuf(i)
 576 !         write(iout,*) i,fac_shield(i)
 577          do j=1,3
 578          iii=iii+1
 579          grad_shield(j,i)=grad_shieldbuf2(iii)
 580          enddo !j
 581          do j=1,ishield_list(i)
 582 !          write (iout,*) "ishild", ishield_list(i),i
 583            shield_list(j,i)=shield_listbuf(j,i)
 584           enddo
 585           do j=1,maxcontsshi
 586           do k=1,3
 587            jjj=jjj+1
 588           grad_shield_loc(k,j,i)=grad_shield_locbuf2(jjj)
 589           grad_shield_side(k,j,i)=grad_shield_sidebuf2(jjj)
 590           enddo !k
 591         enddo !j
 592        enddo !i
 593        endif
 594 #ifdef DEBUG
 595        write(iout,*) "after reduce fac_shield reduce"
 596        do i=1,nres
 597         write(2,*) "fac",itype(i,1),fac_shield(i),grad_shield(1,i)
 598         write(2,*) "list", shield_list(1,i),ishield_list(i), &
 599         grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 600        enddo
 601 #endif
 602 #undef DEBUG
 603        endif
 604
 605
 606
 607 !       print *,"AFTER EGB",ipot,evdw
 608 !mc
 609 !mc Sep-06: egb takes care of dynamic ss bonds too
 610 !mc
 611 !      if (dyn_ss) call dyn_set_nss
 612 !      print *,"Processor",myrank," computed USCSC"
 613 #ifdef TIMING
 614       time01=MPI_Wtime()
 615 #endif
 616       call vec_and_deriv
 617 #ifdef TIMING
 618       time_vec=time_vec+MPI_Wtime()-time01
 619 #endif
 620
 621
 622
 623
 624 !        print *,"Processor",myrank," left VEC_AND_DERIV"
 625       if (ipot.lt.6) then
 626 #ifdef SPLITELE
 627 !         print *,"after ipot if", ipot
 628          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 629              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 630              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 631              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 632 #else
 633          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 634              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 635              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 636              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 637 #endif
 638 !            print *,"just befor eelec call"
 639             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 640 !            print *, "ELEC calc"
 641          else
 642             ees=0.0d0
 643             evdw1=0.0d0
 644             eel_loc=0.0d0
 645             eello_turn3=0.0d0
 646             eello_turn4=0.0d0
 647          endif
 648       else
 649 !        write (iout,*) "Soft-spheer ELEC potential"
 650         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 651          eello_turn4)
 652       endif
 653 !      print *,"Processor",myrank," computed UELEC"
 654 !
 655 ! Calculate excluded-volume interaction energy between peptide groups
 656 ! and side chains.
 657 !
 658 !       write(iout,*) "in etotal calc exc;luded",ipot
 659
 660       if (ipot.lt.6) then
 661        if(wscp.gt.0d0) then
 662         call escp(evdw2,evdw2_14)
 663        else
 664         evdw2=0
 665         evdw2_14=0
 666        endif
 667       else
 668 !        write (iout,*) "Soft-sphere SCP potential"
 669         call escp_soft_sphere(evdw2,evdw2_14)
 670       endif
 671 !        write(iout,*) "in etotal before ebond",ipot
 672
 673 !
 674 ! Calculate the bond-stretching energy
 675 !
 676       call ebond(estr)
 677 !       print *,"EBOND",estr
 678 !       write(iout,*) "in etotal afer ebond",ipot
 679
 680 !
 681 ! Calculate the disulfide-bridge and other energy and the contributions
 682 ! from other distance constraints.
 683 !      print *,'Calling EHPB'
 684       call edis(ehpb)
 685 !elwrite(iout,*) "in etotal afer edis",ipot
 686 !      print *,'EHPB exitted succesfully.'
 687 !
 688 ! Calculate the virtual-bond-angle energy.
 689 !       write(iout,*) "in etotal afer edis",ipot
 690
 691 !      if (wang.gt.0.0d0) then
 692 !        call ebend(ebe,ethetacnstr)
 693 !      else
 694 !        ebe=0
 695 !        ethetacnstr=0
 696 !      endif
 697       if (wang.gt.0d0) then
 698        if (tor_mode.eq.0) then
 699          call ebend(ebe)
 700        else
 701 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 702 !C energy function
 703          call ebend_kcc(ebe)
 704        endif
 705       else
 706         ebe=0.0d0
 707       endif
 708       ethetacnstr=0.0d0
 709       if (with_theta_constr) call etheta_constr(ethetacnstr)
 710
 711 !       write(iout,*) "in etotal afer ebe",ipot
 712
 713 !      print *,"Processor",myrank," computed UB"
 714 !
 715 ! Calculate the SC local energy.
 716 !
 717       call esc(escloc)
 718 !elwrite(iout,*) "in etotal afer esc",ipot
 719 !      print *,"Processor",myrank," computed USC"
 720 !
 721 ! Calculate the virtual-bond torsional energy.
 722 !
 723 !d    print *,'nterm=',nterm
 724 !      if (wtor.gt.0) then
 725 !       call etor(etors,edihcnstr)
 726 !      else
 727 !       etors=0
 728 !       edihcnstr=0
 729 !      endif
 730       if (wtor.gt.0.0d0) then
 731          if (tor_mode.eq.0) then
 732            call etor(etors)
 733          else
 734 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 735 !C energy function
 736            call etor_kcc(etors)
 737          endif
 738       else
 739         etors=0.0d0
 740       endif
 741       edihcnstr=0.0d0
 742       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 743 !c      print *,"Processor",myrank," computed Utor"
 744
 745 !      print *,"Processor",myrank," computed Utor"
 746
 747 !
 748 ! 6/23/01 Calculate double-torsional energy
 749 !
 750 !elwrite(iout,*) "in etotal",ipot
 751       if (wtor_d.gt.0) then
 752        call etor_d(etors_d)
 753       else
 754        etors_d=0
 755       endif
 756 !      print *,"Processor",myrank," computed Utord"
 757 !
 758 ! 21/5/07 Calculate local sicdechain correlation energy
 759 !
 760       if (wsccor.gt.0.0d0) then
 761         call eback_sc_corr(esccor)
 762       else
 763         esccor=0.0d0
 764       endif
 765
 766 !      write(iout,*) "before multibody"
 767       call flush(iout)
 768 !      print *,"Processor",myrank," computed Usccorr"
 769 !
 770 ! 12/1/95 Multi-body terms
 771 !
 772       n_corr=0
 773       n_corr1=0
 774       call flush(iout)
 775       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 776           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 777          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 778 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 779 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 780       else
 781          ecorr=0.0d0
 782          ecorr5=0.0d0
 783          ecorr6=0.0d0
 784          eturn6=0.0d0
 785       endif
 786 !elwrite(iout,*) "in etotal",ipot
 787       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 788          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 789 !d         write (iout,*) "multibody_hb ecorr",ecorr
 790       endif
 791 !      write(iout,*) "afeter  multibody hb"
 792
 793 !      print *,"Processor",myrank," computed Ucorr"
 794 !
 795 ! If performing constraint dynamics, call the constraint energy
 796 !  after the equilibration time
 797       if(usampl.and.totT.gt.eq_time) then
 798 !elwrite(iout,*) "afeter  multibody hb"
 799          call EconstrQ
 800 !elwrite(iout,*) "afeter  multibody hb"
 801          call Econstr_back
 802 !elwrite(iout,*) "afeter  multibody hb"
 803       else
 804          Uconst=0.0d0
 805          Uconst_back=0.0d0
 806       endif
 807       call flush(iout)
 808 !         write(iout,*) "after Econstr"
 809
 810       if (wliptran.gt.0) then
 811 !        print *,"PRZED WYWOLANIEM"
 812         call Eliptransfer(eliptran)
 813       else
 814        eliptran=0.0d0
 815       endif
 816       if (fg_rank.eq.0) then
 817       if (AFMlog.gt.0) then
 818         call AFMforce(Eafmforce)
 819       else if (selfguide.gt.0) then
 820         call AFMvel(Eafmforce)
 821       else
 822         Eafmforce=0.0d0
 823       endif
 824       endif
 825       if (tubemode.eq.1) then
 826        call calctube(etube)
 827       else if (tubemode.eq.2) then
 828        call calctube2(etube)
 829       elseif (tubemode.eq.3) then
 830        call calcnano(etube)
 831       else
 832        etube=0.0d0
 833       endif
 834 !--------------------------------------------------------
 835 !       write (iout,*) "NRES_MOLEC(2),",nres_molec(2)
 836 !      print *,"before",ees,evdw1,ecorr
 837 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 838       if (nres_molec(2).gt.0) then
 839       call ebond_nucl(estr_nucl)
 840       call ebend_nucl(ebe_nucl)
 841       call etor_nucl(etors_nucl)
 842       call esb_gb(evdwsb,eelsb)
 843       call epp_nucl_sub(evdwpp,eespp)
 844       call epsb(evdwpsb,eelpsb)
 845       call esb(esbloc)
 846       call multibody_hb_nucl(ecorr_nucl,ecorr3_nucl,n_corr,n_corr1)
 847             call ecat_nucl(ecation_nucl)
 848       else
 849        etors_nucl=0.0d0
 850        estr_nucl=0.0d0
 851        ecorr3_nucl=0.0d0
 852        ecorr_nucl=0.0d0
 853        ebe_nucl=0.0d0
 854        evdwsb=0.0d0
 855        eelsb=0.0d0
 856        esbloc=0.0d0
 857        evdwpsb=0.0d0
 858        eelpsb=0.0d0
 859        evdwpp=0.0d0
 860        eespp=0.0d0
 861        etors_d_nucl=0.0d0
 862        ecation_nucl=0.0d0
 863       endif
 864 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 865 !      print *,"before ecatcat",wcatcat
 866       if (nres_molec(5).gt.0) then
 867       if (nfgtasks.gt.1) then
 868       if (fg_rank.eq.0) then
 869       call ecatcat(ecationcation)
 870       endif
 871       else
 872       call ecatcat(ecationcation)
 873       endif
 874       if (oldion.gt.0) then
 875       call ecat_prot(ecation_prot)
 876       else
 877       call ecats_prot_amber(ecation_prot)
 878       endif
 879       else
 880       ecationcation=0.0d0
 881       ecation_prot=0.0d0
 882       endif
 883       if ((nres_molec(2).gt.0).and.(nres_molec(1).gt.0)) then
 884       call eprot_sc_base(escbase)
 885       call epep_sc_base(epepbase)
 886       call eprot_sc_phosphate(escpho)
 887       call eprot_pep_phosphate(epeppho)
 888       else
 889       epepbase=0.0
 890       escbase=0.0
 891       escpho=0.0
 892       epeppho=0.0
 893       endif
 894 !      call ecatcat(ecationcation)
 895 !      print *,"after ebend", wtor_nucl
 896 #ifdef TIMING
 897       time_enecalc=time_enecalc+MPI_Wtime()-time00
 898 #endif
 899 !      print *,"Processor",myrank," computed Uconstr"
 900 #ifdef TIMING
 901       time00=MPI_Wtime()
 902 #endif
 903 !
 904 ! Sum the energies
 905 !
 906       energia(1)=evdw
 907 #ifdef SCP14
 908       energia(2)=evdw2-evdw2_14
 909       energia(18)=evdw2_14
 910 #else
 911       energia(2)=evdw2
 912       energia(18)=0.0d0
 913 #endif
 914 #ifdef SPLITELE
 915       energia(3)=ees
 916       energia(16)=evdw1
 917 #else
 918       energia(3)=ees+evdw1
 919       energia(16)=0.0d0
 920 #endif
 921       energia(4)=ecorr
 922       energia(5)=ecorr5
 923       energia(6)=ecorr6
 924       energia(7)=eel_loc
 925       energia(8)=eello_turn3
 926       energia(9)=eello_turn4
 927       energia(10)=eturn6
 928       energia(11)=ebe
 929       energia(12)=escloc
 930       energia(13)=etors
 931       energia(14)=etors_d
 932       energia(15)=ehpb
 933       energia(19)=edihcnstr
 934       energia(17)=estr
 935       energia(20)=Uconst+Uconst_back
 936       energia(21)=esccor
 937       energia(22)=eliptran
 938       energia(23)=Eafmforce
 939       energia(24)=ethetacnstr
 940       energia(25)=etube
 941 !---------------------------------------------------------------
 942       energia(26)=evdwpp
 943       energia(27)=eespp
 944       energia(28)=evdwpsb
 945       energia(29)=eelpsb
 946       energia(30)=evdwsb
 947       energia(31)=eelsb
 948       energia(32)=estr_nucl
 949       energia(33)=ebe_nucl
 950       energia(34)=esbloc
 951       energia(35)=etors_nucl
 952       energia(36)=etors_d_nucl
 953       energia(37)=ecorr_nucl
 954       energia(38)=ecorr3_nucl
 955 !----------------------------------------------------------------------
 956 !    Here are the energies showed per procesor if the are more processors
 957 !    per molecule then we sum it up in sum_energy subroutine
 958 !      print *," Processor",myrank," calls SUM_ENERGY"
 959       energia(42)=ecation_prot
 960       energia(41)=ecationcation
 961       energia(46)=escbase
 962       energia(47)=epepbase
 963       energia(48)=escpho
 964       energia(49)=epeppho
 965 !      energia(50)=ecations_prot_amber
 966       energia(50)=ecation_nucl
 967       call sum_energy(energia,.true.)
 968       if (dyn_ss) call dyn_set_nss
 969 !      print *," Processor",myrank," left SUM_ENERGY"
 970 #ifdef TIMING
 971       time_sumene=time_sumene+MPI_Wtime()-time00
 972 #endif
 973 !        call enerprint(energia)
 974 !elwrite(iout,*)"finish etotal"
 975       return
 976       end subroutine etotal
 977 !-----------------------------------------------------------------------------
 978       subroutine sum_energy(energia,reduce)
 979 !      implicit real*8 (a-h,o-z)
 980 !      include 'DIMENSIONS'
 981 #ifndef ISNAN
 982       external proc_proc
 983 #ifdef WINPGI
 984 !MS$ATTRIBUTES C ::  proc_proc
 985 #endif
 986 #endif
 987 #ifdef MPI
 988       include "mpif.h"
 989 #endif
 990 !      include 'COMMON.SETUP'
 991 !      include 'COMMON.IOUNITS'
 992       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 993 !      include 'COMMON.FFIELD'
 994 !      include 'COMMON.DERIV'
 995 !      include 'COMMON.INTERACT'
 996 !      include 'COMMON.SBRIDGE'
 997 !      include 'COMMON.CHAIN'
 998 !      include 'COMMON.VAR'
 999 !      include 'COMMON.CONTROL'
1000 !      include 'COMMON.TIME1'
1001       logical :: reduce
1002       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
1003       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
1004       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
1005         eliptran,etube, Eafmforce,ethetacnstr
1006       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1007                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1008                       ecorr3_nucl
1009       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber,&
1010                       ecation_nucl
1011       real(kind=8) :: escbase,epepbase,escpho,epeppho
1012       integer :: i
1013 #ifdef MPI
1014       integer :: ierr
1015       real(kind=8) :: time00
1016       if (nfgtasks.gt.1 .and. reduce) then
1017
1018 #ifdef DEBUG
1019         write (iout,*) "energies before REDUCE"
1020         call enerprint(energia)
1021         call flush(iout)
1022 #endif
1023         do i=0,n_ene
1024           enebuff(i)=energia(i)
1025         enddo
1026         time00=MPI_Wtime()
1027         call MPI_Barrier(FG_COMM,IERR)
1028         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
1029         time00=MPI_Wtime()
1030         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
1031           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1032 #ifdef DEBUG
1033         write (iout,*) "energies after REDUCE"
1034         call enerprint(energia)
1035         call flush(iout)
1036 #endif
1037         time_Reduce=time_Reduce+MPI_Wtime()-time00
1038       endif
1039       if (fg_rank.eq.0) then
1040 #endif
1041       evdw=energia(1)
1042 #ifdef SCP14
1043       evdw2=energia(2)+energia(18)
1044       evdw2_14=energia(18)
1045 #else
1046       evdw2=energia(2)
1047 #endif
1048 #ifdef SPLITELE
1049       ees=energia(3)
1050       evdw1=energia(16)
1051 #else
1052       ees=energia(3)
1053       evdw1=0.0d0
1054 #endif
1055       ecorr=energia(4)
1056       ecorr5=energia(5)
1057       ecorr6=energia(6)
1058       eel_loc=energia(7)
1059       eello_turn3=energia(8)
1060       eello_turn4=energia(9)
1061       eturn6=energia(10)
1062       ebe=energia(11)
1063       escloc=energia(12)
1064       etors=energia(13)
1065       etors_d=energia(14)
1066       ehpb=energia(15)
1067       edihcnstr=energia(19)
1068       estr=energia(17)
1069       Uconst=energia(20)
1070       esccor=energia(21)
1071       eliptran=energia(22)
1072       Eafmforce=energia(23)
1073       ethetacnstr=energia(24)
1074       etube=energia(25)
1075       evdwpp=energia(26)
1076       eespp=energia(27)
1077       evdwpsb=energia(28)
1078       eelpsb=energia(29)
1079       evdwsb=energia(30)
1080       eelsb=energia(31)
1081       estr_nucl=energia(32)
1082       ebe_nucl=energia(33)
1083       esbloc=energia(34)
1084       etors_nucl=energia(35)
1085       etors_d_nucl=energia(36)
1086       ecorr_nucl=energia(37)
1087       ecorr3_nucl=energia(38)
1088       ecation_prot=energia(42)
1089       ecationcation=energia(41)
1090       escbase=energia(46)
1091       epepbase=energia(47)
1092       escpho=energia(48)
1093       epeppho=energia(49)
1094       ecation_nucl=energia(50)
1095 !      ecations_prot_amber=energia(50)
1096
1097 !      energia(41)=ecation_prot
1098 !      energia(42)=ecationcation
1099
1100
1101 #ifdef SPLITELE
1102       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
1103        +wang*ebe+wtor*etors+wscloc*escloc &
1104        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1105        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1106        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1107        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1108        +Eafmforce+ethetacnstr  &
1109        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1110        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1111        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1112        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1113        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1114        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho+wcatnucl*ecation_nucl
1115 #else
1116       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
1117        +wang*ebe+wtor*etors+wscloc*escloc &
1118        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1119        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1120        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1121        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1122        +Eafmforce+ethetacnstr &
1123        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1124        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1125        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1126        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1127        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1128        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho+wcatnucl*ecation_nucl
1129 #endif
1130       energia(0)=etot
1131 ! detecting NaNQ
1132 #ifdef ISNAN
1133 #ifdef AIX
1134       if (isnan(etot).ne.0) energia(0)=1.0d+99
1135 #else
1136       if (isnan(etot)) energia(0)=1.0d+99
1137 #endif
1138 #else
1139       i=0
1140 #ifdef WINPGI
1141       idumm=proc_proc(etot,i)
1142 #else
1143       call proc_proc(etot,i)
1144 #endif
1145       if(i.eq.1)energia(0)=1.0d+99
1146 #endif
1147 #ifdef MPI
1148       endif
1149 #endif
1150 !      call enerprint(energia)
1151       call flush(iout)
1152       return
1153       end subroutine sum_energy
1154 !-----------------------------------------------------------------------------
1155       subroutine rescale_weights(t_bath)
1156 !      implicit real*8 (a-h,o-z)
1157 #ifdef MPI
1158       include 'mpif.h'
1159 #endif
1160 !      include 'DIMENSIONS'
1161 !      include 'COMMON.IOUNITS'
1162 !      include 'COMMON.FFIELD'
1163 !      include 'COMMON.SBRIDGE'
1164       real(kind=8) :: kfac=2.4d0
1165       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
1166 !el local variables
1167       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
1168       real(kind=8) :: T0=3.0d2
1169       integer :: ierror
1170 !      facT=temp0/t_bath
1171 !      facT=2*temp0/(t_bath+temp0)
1172       if (rescale_mode.eq.0) then
1173         facT(1)=1.0d0
1174         facT(2)=1.0d0
1175         facT(3)=1.0d0
1176         facT(4)=1.0d0
1177         facT(5)=1.0d0
1178         facT(6)=1.0d0
1179       else if (rescale_mode.eq.1) then
1180         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
1181         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1182         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1183         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1184         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1185 #ifdef WHAM_RUN
1186 !#if defined(WHAM_RUN) || defined(CLUSTER)
1187 #if defined(FUNCTH)
1188 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
1189         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1190 #elif defined(FUNCT)
1191         facT(6)=t_bath/T0
1192 #else
1193         facT(6)=1.0d0
1194 #endif
1195 #endif
1196       else if (rescale_mode.eq.2) then
1197         x=t_bath/temp0
1198         x2=x*x
1199         x3=x2*x
1200         x4=x3*x
1201         x5=x4*x
1202         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
1203         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
1204         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
1205         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
1206         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
1207 #ifdef WHAM_RUN
1208 !#if defined(WHAM_RUN) || defined(CLUSTER)
1209 #if defined(FUNCTH)
1210         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1211 #elif defined(FUNCT)
1212         facT(6)=t_bath/T0
1213 #else
1214         facT(6)=1.0d0
1215 #endif
1216 #endif
1217       else
1218         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1219         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1220 #ifdef MPI
1221        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1222 #endif
1223        stop 555
1224       endif
1225       welec=weights(3)*fact(1)
1226       wcorr=weights(4)*fact(3)
1227       wcorr5=weights(5)*fact(4)
1228       wcorr6=weights(6)*fact(5)
1229       wel_loc=weights(7)*fact(2)
1230       wturn3=weights(8)*fact(2)
1231       wturn4=weights(9)*fact(3)
1232       wturn6=weights(10)*fact(5)
1233       wtor=weights(13)*fact(1)
1234       wtor_d=weights(14)*fact(2)
1235       wsccor=weights(21)*fact(1)
1236       welpsb=weights(28)*fact(1)
1237       wcorr_nucl= weights(37)*fact(1)
1238       wcorr3_nucl=weights(38)*fact(2)
1239       wtor_nucl=  weights(35)*fact(1)
1240       wtor_d_nucl=weights(36)*fact(2)
1241       wpepbase=weights(47)*fact(1)
1242       return
1243       end subroutine rescale_weights
1244 !-----------------------------------------------------------------------------
1245       subroutine enerprint(energia)
1246 !      implicit real*8 (a-h,o-z)
1247 !      include 'DIMENSIONS'
1248 !      include 'COMMON.IOUNITS'
1249 !      include 'COMMON.FFIELD'
1250 !      include 'COMMON.SBRIDGE'
1251 !      include 'COMMON.MD'
1252       real(kind=8) :: energia(0:n_ene)
1253 !el local variables
1254       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
1255       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
1256       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
1257        etube,ethetacnstr,Eafmforce
1258       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1259                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1260                       ecorr3_nucl
1261       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber,&
1262                       ecation_nucl
1263       real(kind=8) :: escbase,epepbase,escpho,epeppho
1264
1265       etot=energia(0)
1266       evdw=energia(1)
1267       evdw2=energia(2)
1268 #ifdef SCP14
1269       evdw2=energia(2)+energia(18)
1270 #else
1271       evdw2=energia(2)
1272 #endif
1273       ees=energia(3)
1274 #ifdef SPLITELE
1275       evdw1=energia(16)
1276 #endif
1277       ecorr=energia(4)
1278       ecorr5=energia(5)
1279       ecorr6=energia(6)
1280       eel_loc=energia(7)
1281       eello_turn3=energia(8)
1282       eello_turn4=energia(9)
1283       eello_turn6=energia(10)
1284       ebe=energia(11)
1285       escloc=energia(12)
1286       etors=energia(13)
1287       etors_d=energia(14)
1288       ehpb=energia(15)
1289       edihcnstr=energia(19)
1290       estr=energia(17)
1291       Uconst=energia(20)
1292       esccor=energia(21)
1293       eliptran=energia(22)
1294       Eafmforce=energia(23)
1295       ethetacnstr=energia(24)
1296       etube=energia(25)
1297       evdwpp=energia(26)
1298       eespp=energia(27)
1299       evdwpsb=energia(28)
1300       eelpsb=energia(29)
1301       evdwsb=energia(30)
1302       eelsb=energia(31)
1303       estr_nucl=energia(32)
1304       ebe_nucl=energia(33)
1305       esbloc=energia(34)
1306       etors_nucl=energia(35)
1307       etors_d_nucl=energia(36)
1308       ecorr_nucl=energia(37)
1309       ecorr3_nucl=energia(38)
1310       ecation_prot=energia(42)
1311       ecationcation=energia(41)
1312       escbase=energia(46)
1313       epepbase=energia(47)
1314       escpho=energia(48)
1315       epeppho=energia(49)
1316       ecation_nucl=energia(50)
1317 !      ecations_prot_amber=energia(50)
1318 #ifdef SPLITELE
1319       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
1320         estr,wbond,ebe,wang,&
1321         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1322         ecorr,wcorr,&
1323         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1324         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
1325         edihcnstr,ethetacnstr,ebr*nss,&
1326         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
1327         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
1328         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1329         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1330         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1331         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat, &
1332         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1333         ecation_nucl,wcatnucl,etot
1334    10 format (/'Virtual-chain energies:'// &
1335        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1336        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1337        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1338        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
1339        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1340        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1341        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1342        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1343        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1344        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1345        ' (SS bridges & dist. cnstr.)'/ &
1346        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1347        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1348        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1349        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1350        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1351        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1352        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1353        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1354        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1355        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1356        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1357        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1358        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1359        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1360        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1361        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1362        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1363        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1364        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1365        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1366        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1367        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1368        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1369        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1370        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1371        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1372        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1373        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1374        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1375        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1376        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1377        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1378        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1379        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1380        'ECATBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(cation nucl-base)'/&
1381        'ETOT=  ',1pE16.6,' (total)')
1382 #else
1383       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1384         estr,wbond,ebe,wang,&
1385         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1386         ecorr,wcorr,&
1387         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1388         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1389         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforce,     &
1390         etube,wtube, &
1391         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1392         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1393         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1394         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1395         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat,  &
1396         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1397         ecation_nucl,wcatnucl,etot
1398    10 format (/'Virtual-chain energies:'// &
1399        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1400        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1401        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1402        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1403        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1404        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1405        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1406        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1407        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1408        ' (SS bridges & dist. cnstr.)'/ &
1409        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1410        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1411        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1412        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1413        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1414        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1415        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1416        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1417        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1418        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1419        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1420        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1421        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1422        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1423        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1424        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1425        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1426        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1427        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1428        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1429        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1430        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1431        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1432        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1433        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1434        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1435        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1436        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1437        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1438        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1439        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1440        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1441        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1442        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1443        'ECATBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(cation nucl-base)'/&
1444        'ETOT=  ',1pE16.6,' (total)')
1445 #endif
1446       return
1447       end subroutine enerprint
1448 !-----------------------------------------------------------------------------
1449       subroutine elj(evdw)
1450 !
1451 ! This subroutine calculates the interaction energy of nonbonded side chains
1452 ! assuming the LJ potential of interaction.
1453 !
1454 !      implicit real*8 (a-h,o-z)
1455 !      include 'DIMENSIONS'
1456       real(kind=8),parameter :: accur=1.0d-10
1457 !      include 'COMMON.GEO'
1458 !      include 'COMMON.VAR'
1459 !      include 'COMMON.LOCAL'
1460 !      include 'COMMON.CHAIN'
1461 !      include 'COMMON.DERIV'
1462 !      include 'COMMON.INTERACT'
1463 !      include 'COMMON.TORSION'
1464 !      include 'COMMON.SBRIDGE'
1465 !      include 'COMMON.NAMES'
1466 !      include 'COMMON.IOUNITS'
1467 !      include 'COMMON.CONTACTS'
1468       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1469       integer :: num_conti
1470 !el local variables
1471       integer :: i,itypi,iint,j,itypi1,itypj,k
1472       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij,sslipi,ssgradlipi,&
1473        aa,bb,sslipj,ssgradlipj
1474       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1475       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1476
1477 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1478       evdw=0.0D0
1479 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1480 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1481 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1482 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1483
1484       do i=iatsc_s,iatsc_e
1485         itypi=iabs(itype(i,1))
1486         if (itypi.eq.ntyp1) cycle
1487         itypi1=iabs(itype(i+1,1))
1488         xi=c(1,nres+i)
1489         yi=c(2,nres+i)
1490         zi=c(3,nres+i)
1491         call to_box(xi,yi,zi)
1492         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1493
1494 ! Change 12/1/95
1495         num_conti=0
1496 !
1497 ! Calculate SC interaction energy.
1498 !
1499         do iint=1,nint_gr(i)
1500 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1501 !d   &                  'iend=',iend(i,iint)
1502           do j=istart(i,iint),iend(i,iint)
1503             itypj=iabs(itype(j,1))
1504             if (itypj.eq.ntyp1) cycle
1505             xj=c(1,nres+j)-xi
1506             yj=c(2,nres+j)-yi
1507             zj=c(3,nres+j)-zi
1508             call to_box(xj,yj,zj)
1509             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1510             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1511              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1512             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1513              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1514             xj=boxshift(xj-xi,boxxsize)
1515             yj=boxshift(yj-yi,boxysize)
1516             zj=boxshift(zj-zi,boxzsize)
1517 ! Change 12/1/95 to calculate four-body interactions
1518             rij=xj*xj+yj*yj+zj*zj
1519             rrij=1.0D0/rij
1520 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1521             eps0ij=eps(itypi,itypj)
1522             fac=rrij**expon2
1523             e1=fac*fac*aa_aq(itypi,itypj)
1524             e2=fac*bb_aq(itypi,itypj)
1525             evdwij=e1+e2
1526 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1527 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1528 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1529 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1530 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1531 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1532             evdw=evdw+evdwij
1533 !
1534 ! Calculate the components of the gradient in DC and X
1535 !
1536             fac=-rrij*(e1+evdwij)
1537             gg(1)=xj*fac
1538             gg(2)=yj*fac
1539             gg(3)=zj*fac
1540             do k=1,3
1541               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1542               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1543               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1544               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1545             enddo
1546 !grad            do k=i,j-1
1547 !grad              do l=1,3
1548 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1549 !grad              enddo
1550 !grad            enddo
1551 !
1552 ! 12/1/95, revised on 5/20/97
1553 !
1554 ! Calculate the contact function. The ith column of the array JCONT will
1555 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1556 ! greater than I). The arrays FACONT and GACONT will contain the values of
1557 ! the contact function and its derivative.
1558 !
1559 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1560 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1561 ! Uncomment next line, if the correlation interactions are contact function only
1562             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1563               rij=dsqrt(rij)
1564               sigij=sigma(itypi,itypj)
1565               r0ij=rs0(itypi,itypj)
1566 !
1567 ! Check whether the SC's are not too far to make a contact.
1568 !
1569               rcut=1.5d0*r0ij
1570               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1571 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1572 !
1573               if (fcont.gt.0.0D0) then
1574 ! If the SC-SC distance if close to sigma, apply spline.
1575 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1576 !Adam &             fcont1,fprimcont1)
1577 !Adam           fcont1=1.0d0-fcont1
1578 !Adam           if (fcont1.gt.0.0d0) then
1579 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1580 !Adam             fcont=fcont*fcont1
1581 !Adam           endif
1582 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1583 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1584 !ga             do k=1,3
1585 !ga               gg(k)=gg(k)*eps0ij
1586 !ga             enddo
1587 !ga             eps0ij=-evdwij*eps0ij
1588 ! Uncomment for AL's type of SC correlation interactions.
1589 !adam           eps0ij=-evdwij
1590                 num_conti=num_conti+1
1591                 jcont(num_conti,i)=j
1592                 facont(num_conti,i)=fcont*eps0ij
1593                 fprimcont=eps0ij*fprimcont/rij
1594                 fcont=expon*fcont
1595 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1596 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1597 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1598 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1599                 gacont(1,num_conti,i)=-fprimcont*xj
1600                 gacont(2,num_conti,i)=-fprimcont*yj
1601                 gacont(3,num_conti,i)=-fprimcont*zj
1602 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1603 !d              write (iout,'(2i3,3f10.5)')
1604 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1605               endif
1606             endif
1607           enddo      ! j
1608         enddo        ! iint
1609 ! Change 12/1/95
1610         num_cont(i)=num_conti
1611       enddo          ! i
1612       do i=1,nct
1613         do j=1,3
1614           gvdwc(j,i)=expon*gvdwc(j,i)
1615           gvdwx(j,i)=expon*gvdwx(j,i)
1616         enddo
1617       enddo
1618 !******************************************************************************
1619 !
1620 !                              N O T E !!!
1621 !
1622 ! To save time, the factor of EXPON has been extracted from ALL components
1623 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1624 ! use!
1625 !
1626 !******************************************************************************
1627       return
1628       end subroutine elj
1629 !-----------------------------------------------------------------------------
1630       subroutine eljk(evdw)
1631 !
1632 ! This subroutine calculates the interaction energy of nonbonded side chains
1633 ! assuming the LJK potential of interaction.
1634 !
1635 !      implicit real*8 (a-h,o-z)
1636 !      include 'DIMENSIONS'
1637 !      include 'COMMON.GEO'
1638 !      include 'COMMON.VAR'
1639 !      include 'COMMON.LOCAL'
1640 !      include 'COMMON.CHAIN'
1641 !      include 'COMMON.DERIV'
1642 !      include 'COMMON.INTERACT'
1643 !      include 'COMMON.IOUNITS'
1644 !      include 'COMMON.NAMES'
1645       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1646       logical :: scheck
1647 !el local variables
1648       integer :: i,iint,j,itypi,itypi1,k,itypj
1649       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij, &
1650          sslipi,ssgradlipi, sslipj,ssgradlipj, aa, bb
1651       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1652
1653 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1654       evdw=0.0D0
1655       do i=iatsc_s,iatsc_e
1656         itypi=iabs(itype(i,1))
1657         if (itypi.eq.ntyp1) cycle
1658         itypi1=iabs(itype(i+1,1))
1659         xi=c(1,nres+i)
1660         yi=c(2,nres+i)
1661         zi=c(3,nres+i)
1662         call to_box(xi,yi,zi)
1663         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1664
1665 !
1666 ! Calculate SC interaction energy.
1667 !
1668         do iint=1,nint_gr(i)
1669           do j=istart(i,iint),iend(i,iint)
1670             itypj=iabs(itype(j,1))
1671             if (itypj.eq.ntyp1) cycle
1672             xj=c(1,nres+j)-xi
1673             yj=c(2,nres+j)-yi
1674             zj=c(3,nres+j)-zi
1675             call to_box(xj,yj,zj)
1676             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1677             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1678              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1679             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1680              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1681             xj=boxshift(xj-xi,boxxsize)
1682             yj=boxshift(yj-yi,boxysize)
1683             zj=boxshift(zj-zi,boxzsize)
1684             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1685             fac_augm=rrij**expon
1686             e_augm=augm(itypi,itypj)*fac_augm
1687             r_inv_ij=dsqrt(rrij)
1688             rij=1.0D0/r_inv_ij
1689             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1690             fac=r_shift_inv**expon
1691             e1=fac*fac*aa_aq(itypi,itypj)
1692             e2=fac*bb_aq(itypi,itypj)
1693             evdwij=e_augm+e1+e2
1694 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1695 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1696 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1697 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1698 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1699 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1700 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1701             evdw=evdw+evdwij
1702 !
1703 ! Calculate the components of the gradient in DC and X
1704 !
1705             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1706             gg(1)=xj*fac
1707             gg(2)=yj*fac
1708             gg(3)=zj*fac
1709             do k=1,3
1710               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1711               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1712               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1713               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1714             enddo
1715 !grad            do k=i,j-1
1716 !grad              do l=1,3
1717 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1718 !grad              enddo
1719 !grad            enddo
1720           enddo      ! j
1721         enddo        ! iint
1722       enddo          ! i
1723       do i=1,nct
1724         do j=1,3
1725           gvdwc(j,i)=expon*gvdwc(j,i)
1726           gvdwx(j,i)=expon*gvdwx(j,i)
1727         enddo
1728       enddo
1729       return
1730       end subroutine eljk
1731 !-----------------------------------------------------------------------------
1732       subroutine ebp(evdw)
1733 !
1734 ! This subroutine calculates the interaction energy of nonbonded side chains
1735 ! assuming the Berne-Pechukas potential of interaction.
1736 !
1737       use comm_srutu
1738       use calc_data
1739 !      implicit real*8 (a-h,o-z)
1740 !      include 'DIMENSIONS'
1741 !      include 'COMMON.GEO'
1742 !      include 'COMMON.VAR'
1743 !      include 'COMMON.LOCAL'
1744 !      include 'COMMON.CHAIN'
1745 !      include 'COMMON.DERIV'
1746 !      include 'COMMON.NAMES'
1747 !      include 'COMMON.INTERACT'
1748 !      include 'COMMON.IOUNITS'
1749 !      include 'COMMON.CALC'
1750       use comm_srutu
1751 !el      integer :: icall
1752 !el      common /srutu/ icall
1753 !     double precision rrsave(maxdim)
1754       logical :: lprn
1755 !el local variables
1756       integer :: iint,itypi,itypi1,itypj
1757       real(kind=8) :: rrij,xi,yi,zi, sslipi,ssgradlipi, sslipj, &
1758         ssgradlipj, aa, bb
1759       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1760
1761 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1762       evdw=0.0D0
1763 !     if (icall.eq.0) then
1764 !       lprn=.true.
1765 !     else
1766         lprn=.false.
1767 !     endif
1768 !el      ind=0
1769       do i=iatsc_s,iatsc_e
1770         itypi=iabs(itype(i,1))
1771         if (itypi.eq.ntyp1) cycle
1772         itypi1=iabs(itype(i+1,1))
1773         xi=c(1,nres+i)
1774         yi=c(2,nres+i)
1775         zi=c(3,nres+i)
1776         call to_box(xi,yi,zi)
1777         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1778         dxi=dc_norm(1,nres+i)
1779         dyi=dc_norm(2,nres+i)
1780         dzi=dc_norm(3,nres+i)
1781 !        dsci_inv=dsc_inv(itypi)
1782         dsci_inv=vbld_inv(i+nres)
1783 !
1784 ! Calculate SC interaction energy.
1785 !
1786         do iint=1,nint_gr(i)
1787           do j=istart(i,iint),iend(i,iint)
1788 !el            ind=ind+1
1789             itypj=iabs(itype(j,1))
1790             if (itypj.eq.ntyp1) cycle
1791 !            dscj_inv=dsc_inv(itypj)
1792             dscj_inv=vbld_inv(j+nres)
1793             chi1=chi(itypi,itypj)
1794             chi2=chi(itypj,itypi)
1795             chi12=chi1*chi2
1796             chip1=chip(itypi)
1797             chip2=chip(itypj)
1798             chip12=chip1*chip2
1799             alf1=alp(itypi)
1800             alf2=alp(itypj)
1801             alf12=0.5D0*(alf1+alf2)
1802 ! For diagnostics only!!!
1803 !           chi1=0.0D0
1804 !           chi2=0.0D0
1805 !           chi12=0.0D0
1806 !           chip1=0.0D0
1807 !           chip2=0.0D0
1808 !           chip12=0.0D0
1809 !           alf1=0.0D0
1810 !           alf2=0.0D0
1811 !           alf12=0.0D0
1812             xj=c(1,nres+j)-xi
1813             yj=c(2,nres+j)-yi
1814             zj=c(3,nres+j)-zi
1815             call to_box(xj,yj,zj)
1816             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1817             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1818              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1819             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1820              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1821             xj=boxshift(xj-xi,boxxsize)
1822             yj=boxshift(yj-yi,boxysize)
1823             zj=boxshift(zj-zi,boxzsize)
1824             dxj=dc_norm(1,nres+j)
1825             dyj=dc_norm(2,nres+j)
1826             dzj=dc_norm(3,nres+j)
1827             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1828 !d          if (icall.eq.0) then
1829 !d            rrsave(ind)=rrij
1830 !d          else
1831 !d            rrij=rrsave(ind)
1832 !d          endif
1833             rij=dsqrt(rrij)
1834 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1835             call sc_angular
1836 ! Calculate whole angle-dependent part of epsilon and contributions
1837 ! to its derivatives
1838             fac=(rrij*sigsq)**expon2
1839             e1=fac*fac*aa_aq(itypi,itypj)
1840             e2=fac*bb_aq(itypi,itypj)
1841             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1842             eps2der=evdwij*eps3rt
1843             eps3der=evdwij*eps2rt
1844             evdwij=evdwij*eps2rt*eps3rt
1845             evdw=evdw+evdwij
1846             if (lprn) then
1847             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1848             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1849 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1850 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1851 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1852 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1853 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1854 !d     &        evdwij
1855             endif
1856 ! Calculate gradient components.
1857             e1=e1*eps1*eps2rt**2*eps3rt**2
1858             fac=-expon*(e1+evdwij)
1859             sigder=fac/sigsq
1860             fac=rrij*fac
1861 ! Calculate radial part of the gradient
1862             gg(1)=xj*fac
1863             gg(2)=yj*fac
1864             gg(3)=zj*fac
1865 ! Calculate the angular part of the gradient and sum add the contributions
1866 ! to the appropriate components of the Cartesian gradient.
1867             call sc_grad
1868           enddo      ! j
1869         enddo        ! iint
1870       enddo          ! i
1871 !     stop
1872       return
1873       end subroutine ebp
1874 !-----------------------------------------------------------------------------
1875       subroutine egb(evdw)
1876 !
1877 ! This subroutine calculates the interaction energy of nonbonded side chains
1878 ! assuming the Gay-Berne potential of interaction.
1879 !
1880       use calc_data
1881 !      implicit real*8 (a-h,o-z)
1882 !      include 'DIMENSIONS'
1883 !      include 'COMMON.GEO'
1884 !      include 'COMMON.VAR'
1885 !      include 'COMMON.LOCAL'
1886 !      include 'COMMON.CHAIN'
1887 !      include 'COMMON.DERIV'
1888 !      include 'COMMON.NAMES'
1889 !      include 'COMMON.INTERACT'
1890 !      include 'COMMON.IOUNITS'
1891 !      include 'COMMON.CALC'
1892 !      include 'COMMON.CONTROL'
1893 !      include 'COMMON.SBRIDGE'
1894       logical :: lprn
1895 !el local variables
1896       integer :: iint,itypi,itypi1,itypj,subchap,icont
1897       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1898       real(kind=8) :: evdw,sig0ij
1899       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1900                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1901                     sslipi,sslipj,faclip
1902       integer :: ii
1903       real(kind=8) :: fracinbuf
1904
1905 !cccc      energy_dec=.false.
1906 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1907       evdw=0.0D0
1908       lprn=.false.
1909 !     if (icall.eq.0) lprn=.false.
1910 !el      ind=0
1911       dCAVdOM2=0.0d0
1912       dGCLdOM2=0.0d0
1913       dPOLdOM2=0.0d0
1914       dCAVdOM1=0.0d0
1915       dGCLdOM1=0.0d0
1916       dPOLdOM1=0.0d0
1917 !             write (iout,*) "RWA", g_listscsc_start,g_listscsc_end,i,j
1918
1919       do icont=g_listscsc_start,g_listscsc_end
1920       i=newcontlisti(icont)
1921       j=newcontlistj(icont)
1922 !      write (iout,*) "RWA", g_listscsc_start,g_listscsc_end,i,j
1923 !      do i=iatsc_s,iatsc_e
1924 !C        print *,"I am in EVDW",i
1925         itypi=iabs(itype(i,1))
1926 !        if (i.ne.47) cycle
1927         if (itypi.eq.ntyp1) cycle
1928         itypi1=iabs(itype(i+1,1))
1929         xi=c(1,nres+i)
1930         yi=c(2,nres+i)
1931         zi=c(3,nres+i)
1932         call to_box(xi,yi,zi)
1933         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1934
1935         dxi=dc_norm(1,nres+i)
1936         dyi=dc_norm(2,nres+i)
1937         dzi=dc_norm(3,nres+i)
1938 !        dsci_inv=dsc_inv(itypi)
1939         dsci_inv=vbld_inv(i+nres)
1940 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1941 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1942 !
1943 ! Calculate SC interaction energy.
1944 !
1945 !        do iint=1,nint_gr(i)
1946 !          do j=istart(i,iint),iend(i,iint)
1947             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1948               call dyn_ssbond_ene(i,j,evdwij)
1949               evdw=evdw+evdwij
1950               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1951                               'evdw',i,j,evdwij,' ss'
1952 !              if (energy_dec) write (iout,*) &
1953 !                              'evdw',i,j,evdwij,' ss'
1954              do k=j+1,iend(i,iint)
1955 !C search over all next residues
1956               if (dyn_ss_mask(k)) then
1957 !C check if they are cysteins
1958 !C              write(iout,*) 'k=',k
1959
1960 !c              write(iout,*) "PRZED TRI", evdwij
1961 !               evdwij_przed_tri=evdwij
1962               call triple_ssbond_ene(i,j,k,evdwij)
1963 !c               if(evdwij_przed_tri.ne.evdwij) then
1964 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1965 !c               endif
1966
1967 !c              write(iout,*) "PO TRI", evdwij
1968 !C call the energy function that removes the artifical triple disulfide
1969 !C bond the soubroutine is located in ssMD.F
1970               evdw=evdw+evdwij
1971               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1972                             'evdw',i,j,evdwij,'tss'
1973               endif!dyn_ss_mask(k)
1974              enddo! k
1975             ELSE
1976 !el            ind=ind+1
1977             itypj=iabs(itype(j,1))
1978             if (itypj.eq.ntyp1) cycle
1979 !             if (j.ne.78) cycle
1980 !            dscj_inv=dsc_inv(itypj)
1981             dscj_inv=vbld_inv(j+nres)
1982 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1983 !              1.0d0/vbld(j+nres) !d
1984 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1985             sig0ij=sigma(itypi,itypj)
1986             chi1=chi(itypi,itypj)
1987             chi2=chi(itypj,itypi)
1988             chi12=chi1*chi2
1989             chip1=chip(itypi)
1990             chip2=chip(itypj)
1991             chip12=chip1*chip2
1992             alf1=alp(itypi)
1993             alf2=alp(itypj)
1994             alf12=0.5D0*(alf1+alf2)
1995 ! For diagnostics only!!!
1996 !           chi1=0.0D0
1997 !           chi2=0.0D0
1998 !           chi12=0.0D0
1999 !           chip1=0.0D0
2000 !           chip2=0.0D0
2001 !           chip12=0.0D0
2002 !           alf1=0.0D0
2003 !           alf2=0.0D0
2004 !           alf12=0.0D0
2005            xj=c(1,nres+j)
2006            yj=c(2,nres+j)
2007            zj=c(3,nres+j)
2008               call to_box(xj,yj,zj)
2009               call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2010 !              write (iout,*) "KWA2", itypi,itypj
2011               aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2012                +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2013               bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2014                +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2015               xj=boxshift(xj-xi,boxxsize)
2016               yj=boxshift(yj-yi,boxysize)
2017               zj=boxshift(zj-zi,boxzsize)
2018             dxj=dc_norm(1,nres+j)
2019             dyj=dc_norm(2,nres+j)
2020             dzj=dc_norm(3,nres+j)
2021 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2022 !            write (iout,*) "j",j," dc_norm",& !d
2023 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2024 !          write(iout,*)"rrij ",rrij
2025 !          write(iout,*)"xj yj zj ", xj, yj, zj
2026 !          write(iout,*)"xi yi zi ", xi, yi, zi
2027 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
2028             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2029             rij=dsqrt(rrij)
2030             sss_ele_cut=sscale_ele(1.0d0/(rij))
2031             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
2032 !            print *,sss_ele_cut,sss_ele_grad,&
2033 !            1.0d0/(rij),r_cut_ele,rlamb_ele
2034             if (sss_ele_cut.le.0.0) cycle
2035 ! Calculate angle-dependent terms of energy and contributions to their
2036 ! derivatives.
2037             call sc_angular
2038             sigsq=1.0D0/sigsq
2039             sig=sig0ij*dsqrt(sigsq)
2040             rij_shift=1.0D0/rij-sig+sig0ij
2041 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
2042 !            "sig0ij",sig0ij
2043 ! for diagnostics; uncomment
2044 !            rij_shift=1.2*sig0ij
2045 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2046             if (rij_shift.le.0.0D0) then
2047               evdw=1.0D20
2048 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2049 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
2050 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2051               return
2052             endif
2053             sigder=-sig*sigsq
2054 !---------------------------------------------------------------
2055             rij_shift=1.0D0/rij_shift
2056             fac=rij_shift**expon
2057             faclip=fac
2058             e1=fac*fac*aa!(itypi,itypj)
2059             e2=fac*bb!(itypi,itypj)
2060             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2061             eps2der=evdwij*eps3rt
2062             eps3der=evdwij*eps2rt
2063 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
2064 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
2065 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
2066             evdwij=evdwij*eps2rt*eps3rt
2067             evdw=evdw+evdwij*sss_ele_cut
2068             if (lprn) then
2069             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2070             epsi=bb**2/aa!(itypi,itypj)
2071             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2072               restyp(itypi,1),i,restyp(itypj,1),j, &
2073               epsi,sigm,chi1,chi2,chip1,chip2, &
2074               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
2075               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
2076               evdwij
2077             endif
2078
2079             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
2080                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
2081 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
2082 !            if (energy_dec) write (iout,*) &
2083 !                             'evdw',i,j,evdwij
2084 !                       print *,"ZALAMKA", evdw
2085
2086 ! Calculate gradient components.
2087             e1=e1*eps1*eps2rt**2*eps3rt**2
2088             fac=-expon*(e1+evdwij)*rij_shift
2089             sigder=fac*sigder
2090             fac=rij*fac
2091 !            print *,'before fac',fac,rij,evdwij
2092             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
2093             *rij
2094 !            print *,'grad part scale',fac,   &
2095 !             evdwij*sss_ele_grad/sss_ele_cut &
2096 !            /sigma(itypi,itypj)*rij
2097 !            fac=0.0d0
2098 ! Calculate the radial part of the gradient
2099             gg(1)=xj*fac
2100             gg(2)=yj*fac
2101             gg(3)=zj*fac
2102 !C Calculate the radial part of the gradient
2103             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
2104        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
2105         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
2106        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2107             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2108             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2109
2110 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
2111 ! Calculate angular part of the gradient.
2112             call sc_grad
2113             ENDIF    ! dyn_ss
2114 !          enddo      ! j
2115 !        enddo        ! iint
2116       enddo          ! i
2117 !       print *,"ZALAMKA", evdw
2118 !      write (iout,*) "Number of loop steps in EGB:",ind
2119 !ccc      energy_dec=.false.
2120       return
2121       end subroutine egb
2122 !-----------------------------------------------------------------------------
2123       subroutine egbv(evdw)
2124 !
2125 ! This subroutine calculates the interaction energy of nonbonded side chains
2126 ! assuming the Gay-Berne-Vorobjev potential of interaction.
2127 !
2128       use comm_srutu
2129       use calc_data
2130 !      implicit real*8 (a-h,o-z)
2131 !      include 'DIMENSIONS'
2132 !      include 'COMMON.GEO'
2133 !      include 'COMMON.VAR'
2134 !      include 'COMMON.LOCAL'
2135 !      include 'COMMON.CHAIN'
2136 !      include 'COMMON.DERIV'
2137 !      include 'COMMON.NAMES'
2138 !      include 'COMMON.INTERACT'
2139 !      include 'COMMON.IOUNITS'
2140 !      include 'COMMON.CALC'
2141       use comm_srutu
2142 !el      integer :: icall
2143 !el      common /srutu/ icall
2144       logical :: lprn
2145 !el local variables
2146       integer :: iint,itypi,itypi1,itypj
2147       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2, &
2148          sigm,sslipi,ssgradlipi, sslipj,ssgradlipj, aa, bb
2149       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
2150
2151 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2152       evdw=0.0D0
2153       lprn=.false.
2154 !     if (icall.eq.0) lprn=.true.
2155 !el      ind=0
2156       do i=iatsc_s,iatsc_e
2157         itypi=iabs(itype(i,1))
2158         if (itypi.eq.ntyp1) cycle
2159         itypi1=iabs(itype(i+1,1))
2160         xi=c(1,nres+i)
2161         yi=c(2,nres+i)
2162         zi=c(3,nres+i)
2163         call to_box(xi,yi,zi)
2164         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2165         dxi=dc_norm(1,nres+i)
2166         dyi=dc_norm(2,nres+i)
2167         dzi=dc_norm(3,nres+i)
2168 !        dsci_inv=dsc_inv(itypi)
2169         dsci_inv=vbld_inv(i+nres)
2170 !
2171 ! Calculate SC interaction energy.
2172 !
2173         do iint=1,nint_gr(i)
2174           do j=istart(i,iint),iend(i,iint)
2175 !el            ind=ind+1
2176             itypj=iabs(itype(j,1))
2177             if (itypj.eq.ntyp1) cycle
2178 !            dscj_inv=dsc_inv(itypj)
2179             dscj_inv=vbld_inv(j+nres)
2180             sig0ij=sigma(itypi,itypj)
2181             r0ij=r0(itypi,itypj)
2182             chi1=chi(itypi,itypj)
2183             chi2=chi(itypj,itypi)
2184             chi12=chi1*chi2
2185             chip1=chip(itypi)
2186             chip2=chip(itypj)
2187             chip12=chip1*chip2
2188             alf1=alp(itypi)
2189             alf2=alp(itypj)
2190             alf12=0.5D0*(alf1+alf2)
2191 ! For diagnostics only!!!
2192 !           chi1=0.0D0
2193 !           chi2=0.0D0
2194 !           chi12=0.0D0
2195 !           chip1=0.0D0
2196 !           chip2=0.0D0
2197 !           chip12=0.0D0
2198 !           alf1=0.0D0
2199 !           alf2=0.0D0
2200 !           alf12=0.0D0
2201             xj=c(1,nres+j)-xi
2202             yj=c(2,nres+j)-yi
2203             zj=c(3,nres+j)-zi
2204            call to_box(xj,yj,zj)
2205            call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2206            aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2207             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2208            bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2209             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2210            xj=boxshift(xj-xi,boxxsize)
2211            yj=boxshift(yj-yi,boxysize)
2212            zj=boxshift(zj-zi,boxzsize)
2213             dxj=dc_norm(1,nres+j)
2214             dyj=dc_norm(2,nres+j)
2215             dzj=dc_norm(3,nres+j)
2216             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2217             rij=dsqrt(rrij)
2218 ! Calculate angle-dependent terms of energy and contributions to their
2219 ! derivatives.
2220             call sc_angular
2221             sigsq=1.0D0/sigsq
2222             sig=sig0ij*dsqrt(sigsq)
2223             rij_shift=1.0D0/rij-sig+r0ij
2224 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2225             if (rij_shift.le.0.0D0) then
2226               evdw=1.0D20
2227               return
2228             endif
2229             sigder=-sig*sigsq
2230 !---------------------------------------------------------------
2231             rij_shift=1.0D0/rij_shift
2232             fac=rij_shift**expon
2233             e1=fac*fac*aa_aq(itypi,itypj)
2234             e2=fac*bb_aq(itypi,itypj)
2235             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2236             eps2der=evdwij*eps3rt
2237             eps3der=evdwij*eps2rt
2238             fac_augm=rrij**expon
2239             e_augm=augm(itypi,itypj)*fac_augm
2240             evdwij=evdwij*eps2rt*eps3rt
2241             evdw=evdw+evdwij+e_augm
2242             if (lprn) then
2243             sigm=dabs(aa_aq(itypi,itypj)/&
2244             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
2245             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
2246             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2247               restyp(itypi,1),i,restyp(itypj,1),j,&
2248               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
2249               chi1,chi2,chip1,chip2,&
2250               eps1,eps2rt**2,eps3rt**2,&
2251               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
2252               evdwij+e_augm
2253             endif
2254 ! Calculate gradient components.
2255             e1=e1*eps1*eps2rt**2*eps3rt**2
2256             fac=-expon*(e1+evdwij)*rij_shift
2257             sigder=fac*sigder
2258             fac=rij*fac-2*expon*rrij*e_augm
2259 ! Calculate the radial part of the gradient
2260             gg(1)=xj*fac
2261             gg(2)=yj*fac
2262             gg(3)=zj*fac
2263 ! Calculate angular part of the gradient.
2264             call sc_grad
2265           enddo      ! j
2266         enddo        ! iint
2267       enddo          ! i
2268       end subroutine egbv
2269 !-----------------------------------------------------------------------------
2270 !el      subroutine sc_angular in module geometry
2271 !-----------------------------------------------------------------------------
2272       subroutine e_softsphere(evdw)
2273 !
2274 ! This subroutine calculates the interaction energy of nonbonded side chains
2275 ! assuming the LJ potential of interaction.
2276 !
2277 !      implicit real*8 (a-h,o-z)
2278 !      include 'DIMENSIONS'
2279       real(kind=8),parameter :: accur=1.0d-10
2280 !      include 'COMMON.GEO'
2281 !      include 'COMMON.VAR'
2282 !      include 'COMMON.LOCAL'
2283 !      include 'COMMON.CHAIN'
2284 !      include 'COMMON.DERIV'
2285 !      include 'COMMON.INTERACT'
2286 !      include 'COMMON.TORSION'
2287 !      include 'COMMON.SBRIDGE'
2288 !      include 'COMMON.NAMES'
2289 !      include 'COMMON.IOUNITS'
2290 !      include 'COMMON.CONTACTS'
2291       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
2292 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2293 !el local variables
2294       integer :: i,iint,j,itypi,itypi1,itypj,k
2295       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
2296       real(kind=8) :: fac
2297
2298       evdw=0.0D0
2299       do i=iatsc_s,iatsc_e
2300         itypi=iabs(itype(i,1))
2301         if (itypi.eq.ntyp1) cycle
2302         itypi1=iabs(itype(i+1,1))
2303         xi=c(1,nres+i)
2304         yi=c(2,nres+i)
2305         zi=c(3,nres+i)
2306         call to_box(xi,yi,zi)
2307
2308 !
2309 ! Calculate SC interaction energy.
2310 !
2311         do iint=1,nint_gr(i)
2312 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2313 !d   &                  'iend=',iend(i,iint)
2314           do j=istart(i,iint),iend(i,iint)
2315             itypj=iabs(itype(j,1))
2316             if (itypj.eq.ntyp1) cycle
2317             xj=boxshift(c(1,nres+j)-xi,boxxsize)
2318             yj=boxshift(c(2,nres+j)-yi,boxysize)
2319             zj=boxshift(c(3,nres+j)-zi,boxzsize)
2320             rij=xj*xj+yj*yj+zj*zj
2321 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2322             r0ij=r0(itypi,itypj)
2323             r0ijsq=r0ij*r0ij
2324 !            print *,i,j,r0ij,dsqrt(rij)
2325             if (rij.lt.r0ijsq) then
2326               evdwij=0.25d0*(rij-r0ijsq)**2
2327               fac=rij-r0ijsq
2328             else
2329               evdwij=0.0d0
2330               fac=0.0d0
2331             endif
2332             evdw=evdw+evdwij
2333 !
2334 ! Calculate the components of the gradient in DC and X
2335 !
2336             gg(1)=xj*fac
2337             gg(2)=yj*fac
2338             gg(3)=zj*fac
2339             do k=1,3
2340               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2341               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2342               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2343               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2344             enddo
2345 !grad            do k=i,j-1
2346 !grad              do l=1,3
2347 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2348 !grad              enddo
2349 !grad            enddo
2350           enddo ! j
2351         enddo ! iint
2352       enddo ! i
2353       return
2354       end subroutine e_softsphere
2355 !-----------------------------------------------------------------------------
2356       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2357 !
2358 ! Soft-sphere potential of p-p interaction
2359 !
2360 !      implicit real*8 (a-h,o-z)
2361 !      include 'DIMENSIONS'
2362 !      include 'COMMON.CONTROL'
2363 !      include 'COMMON.IOUNITS'
2364 !      include 'COMMON.GEO'
2365 !      include 'COMMON.VAR'
2366 !      include 'COMMON.LOCAL'
2367 !      include 'COMMON.CHAIN'
2368 !      include 'COMMON.DERIV'
2369 !      include 'COMMON.INTERACT'
2370 !      include 'COMMON.CONTACTS'
2371 !      include 'COMMON.TORSION'
2372 !      include 'COMMON.VECTORS'
2373 !      include 'COMMON.FFIELD'
2374       real(kind=8),dimension(3) :: ggg
2375 !d      write(iout,*) 'In EELEC_soft_sphere'
2376 !el local variables
2377       integer :: i,j,k,num_conti,iteli,itelj
2378       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2379       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2380       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2381
2382       ees=0.0D0
2383       evdw1=0.0D0
2384       eel_loc=0.0d0
2385       eello_turn3=0.0d0
2386       eello_turn4=0.0d0
2387 !el      ind=0
2388       do i=iatel_s,iatel_e
2389         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2390         dxi=dc(1,i)
2391         dyi=dc(2,i)
2392         dzi=dc(3,i)
2393         xmedi=c(1,i)+0.5d0*dxi
2394         ymedi=c(2,i)+0.5d0*dyi
2395         zmedi=c(3,i)+0.5d0*dzi
2396         call to_box(xmedi,ymedi,zmedi)
2397         num_conti=0
2398 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2399         do j=ielstart(i),ielend(i)
2400           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2401 !el          ind=ind+1
2402           iteli=itel(i)
2403           itelj=itel(j)
2404           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2405           r0ij=rpp(iteli,itelj)
2406           r0ijsq=r0ij*r0ij
2407           dxj=dc(1,j)
2408           dyj=dc(2,j)
2409           dzj=dc(3,j)
2410           xj=c(1,j)+0.5D0*dxj-xmedi
2411           yj=c(2,j)+0.5D0*dyj-ymedi
2412           zj=c(3,j)+0.5D0*dzj-zmedi
2413           call to_box(xj,yj,zj)
2414           xj=boxshift(xj-xmedi,boxxsize)
2415           yj=boxshift(yj-ymedi,boxysize)
2416           zj=boxshift(zj-zmedi,boxzsize)
2417           rij=xj*xj+yj*yj+zj*zj
2418           if (rij.lt.r0ijsq) then
2419             evdw1ij=0.25d0*(rij-r0ijsq)**2
2420             fac=rij-r0ijsq
2421           else
2422             evdw1ij=0.0d0
2423             fac=0.0d0
2424           endif
2425           evdw1=evdw1+evdw1ij
2426 !
2427 ! Calculate contributions to the Cartesian gradient.
2428 !
2429           ggg(1)=fac*xj
2430           ggg(2)=fac*yj
2431           ggg(3)=fac*zj
2432           do k=1,3
2433             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2434             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2435           enddo
2436 !
2437 ! Loop over residues i+1 thru j-1.
2438 !
2439 !grad          do k=i+1,j-1
2440 !grad            do l=1,3
2441 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2442 !grad            enddo
2443 !grad          enddo
2444         enddo ! j
2445       enddo   ! i
2446 !grad      do i=nnt,nct-1
2447 !grad        do k=1,3
2448 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2449 !grad        enddo
2450 !grad        do j=i+1,nct-1
2451 !grad          do k=1,3
2452 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2453 !grad          enddo
2454 !grad        enddo
2455 !grad      enddo
2456       return
2457       end subroutine eelec_soft_sphere
2458 !-----------------------------------------------------------------------------
2459       subroutine vec_and_deriv
2460 !      implicit real*8 (a-h,o-z)
2461 !      include 'DIMENSIONS'
2462 #ifdef MPI
2463       include 'mpif.h'
2464 #endif
2465 !      include 'COMMON.IOUNITS'
2466 !      include 'COMMON.GEO'
2467 !      include 'COMMON.VAR'
2468 !      include 'COMMON.LOCAL'
2469 !      include 'COMMON.CHAIN'
2470 !      include 'COMMON.VECTORS'
2471 !      include 'COMMON.SETUP'
2472 !      include 'COMMON.TIME1'
2473       real(kind=8),dimension(3,3,2) :: uyder,uzder
2474       real(kind=8),dimension(2) :: vbld_inv_temp
2475 ! Compute the local reference systems. For reference system (i), the
2476 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2477 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2478 !el local variables
2479       integer :: i,j,k,l
2480       real(kind=8) :: facy,fac,costh
2481
2482 #ifdef PARVEC
2483       do i=ivec_start,ivec_end
2484 #else
2485       do i=1,nres-1
2486 #endif
2487           if (i.eq.nres-1) then
2488 ! Case of the last full residue
2489 ! Compute the Z-axis
2490             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2491             costh=dcos(pi-theta(nres))
2492             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2493             do k=1,3
2494               uz(k,i)=fac*uz(k,i)
2495             enddo
2496 ! Compute the derivatives of uz
2497             uzder(1,1,1)= 0.0d0
2498             uzder(2,1,1)=-dc_norm(3,i-1)
2499             uzder(3,1,1)= dc_norm(2,i-1)
2500             uzder(1,2,1)= dc_norm(3,i-1)
2501             uzder(2,2,1)= 0.0d0
2502             uzder(3,2,1)=-dc_norm(1,i-1)
2503             uzder(1,3,1)=-dc_norm(2,i-1)
2504             uzder(2,3,1)= dc_norm(1,i-1)
2505             uzder(3,3,1)= 0.0d0
2506             uzder(1,1,2)= 0.0d0
2507             uzder(2,1,2)= dc_norm(3,i)
2508             uzder(3,1,2)=-dc_norm(2,i)
2509             uzder(1,2,2)=-dc_norm(3,i)
2510             uzder(2,2,2)= 0.0d0
2511             uzder(3,2,2)= dc_norm(1,i)
2512             uzder(1,3,2)= dc_norm(2,i)
2513             uzder(2,3,2)=-dc_norm(1,i)
2514             uzder(3,3,2)= 0.0d0
2515 ! Compute the Y-axis
2516             facy=fac
2517             do k=1,3
2518               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2519             enddo
2520 ! Compute the derivatives of uy
2521             do j=1,3
2522               do k=1,3
2523                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2524                               -dc_norm(k,i)*dc_norm(j,i-1)
2525                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2526               enddo
2527               uyder(j,j,1)=uyder(j,j,1)-costh
2528               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2529             enddo
2530             do j=1,2
2531               do k=1,3
2532                 do l=1,3
2533                   uygrad(l,k,j,i)=uyder(l,k,j)
2534                   uzgrad(l,k,j,i)=uzder(l,k,j)
2535                 enddo
2536               enddo
2537             enddo
2538             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2539             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2540             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2541             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2542           else
2543 ! Other residues
2544 ! Compute the Z-axis
2545             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2546             costh=dcos(pi-theta(i+2))
2547             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2548             do k=1,3
2549               uz(k,i)=fac*uz(k,i)
2550             enddo
2551 ! Compute the derivatives of uz
2552             uzder(1,1,1)= 0.0d0
2553             uzder(2,1,1)=-dc_norm(3,i+1)
2554             uzder(3,1,1)= dc_norm(2,i+1)
2555             uzder(1,2,1)= dc_norm(3,i+1)
2556             uzder(2,2,1)= 0.0d0
2557             uzder(3,2,1)=-dc_norm(1,i+1)
2558             uzder(1,3,1)=-dc_norm(2,i+1)
2559             uzder(2,3,1)= dc_norm(1,i+1)
2560             uzder(3,3,1)= 0.0d0
2561             uzder(1,1,2)= 0.0d0
2562             uzder(2,1,2)= dc_norm(3,i)
2563             uzder(3,1,2)=-dc_norm(2,i)
2564             uzder(1,2,2)=-dc_norm(3,i)
2565             uzder(2,2,2)= 0.0d0
2566             uzder(3,2,2)= dc_norm(1,i)
2567             uzder(1,3,2)= dc_norm(2,i)
2568             uzder(2,3,2)=-dc_norm(1,i)
2569             uzder(3,3,2)= 0.0d0
2570 ! Compute the Y-axis
2571             facy=fac
2572             do k=1,3
2573               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2574             enddo
2575 ! Compute the derivatives of uy
2576             do j=1,3
2577               do k=1,3
2578                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2579                               -dc_norm(k,i)*dc_norm(j,i+1)
2580                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2581               enddo
2582               uyder(j,j,1)=uyder(j,j,1)-costh
2583               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2584             enddo
2585             do j=1,2
2586               do k=1,3
2587                 do l=1,3
2588                   uygrad(l,k,j,i)=uyder(l,k,j)
2589                   uzgrad(l,k,j,i)=uzder(l,k,j)
2590                 enddo
2591               enddo
2592             enddo
2593             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2594             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2595             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2596             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2597           endif
2598       enddo
2599       do i=1,nres-1
2600         vbld_inv_temp(1)=vbld_inv(i+1)
2601         if (i.lt.nres-1) then
2602           vbld_inv_temp(2)=vbld_inv(i+2)
2603           else
2604           vbld_inv_temp(2)=vbld_inv(i)
2605           endif
2606         do j=1,2
2607           do k=1,3
2608             do l=1,3
2609               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2610               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2611             enddo
2612           enddo
2613         enddo
2614       enddo
2615 #if defined(PARVEC) && defined(MPI)
2616       if (nfgtasks1.gt.1) then
2617         time00=MPI_Wtime()
2618 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2619 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2620 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2621         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2622          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2623          FG_COMM1,IERR)
2624         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2625          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2626          FG_COMM1,IERR)
2627         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2628          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2629          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2630         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2631          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2632          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2633         time_gather=time_gather+MPI_Wtime()-time00
2634       endif
2635 !      if (fg_rank.eq.0) then
2636 !        write (iout,*) "Arrays UY and UZ"
2637 !        do i=1,nres-1
2638 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2639 !     &     (uz(k,i),k=1,3)
2640 !        enddo
2641 !      endif
2642 #endif
2643       return
2644       end subroutine vec_and_deriv
2645 !-----------------------------------------------------------------------------
2646       subroutine check_vecgrad
2647 !      implicit real*8 (a-h,o-z)
2648 !      include 'DIMENSIONS'
2649 !      include 'COMMON.IOUNITS'
2650 !      include 'COMMON.GEO'
2651 !      include 'COMMON.VAR'
2652 !      include 'COMMON.LOCAL'
2653 !      include 'COMMON.CHAIN'
2654 !      include 'COMMON.VECTORS'
2655       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2656       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2657       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2658       real(kind=8),dimension(3) :: erij
2659       real(kind=8) :: delta=1.0d-7
2660 !el local variables
2661       integer :: i,j,k,l
2662
2663       call vec_and_deriv
2664 !d      do i=1,nres
2665 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2666 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2667 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2668 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2669 !d     &     (dc_norm(if90,i),if90=1,3)
2670 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2671 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2672 !d          write(iout,'(a)')
2673 !d      enddo
2674       do i=1,nres
2675         do j=1,2
2676           do k=1,3
2677             do l=1,3
2678               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2679               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2680             enddo
2681           enddo
2682         enddo
2683       enddo
2684       call vec_and_deriv
2685       do i=1,nres
2686         do j=1,3
2687           uyt(j,i)=uy(j,i)
2688           uzt(j,i)=uz(j,i)
2689         enddo
2690       enddo
2691       do i=1,nres
2692 !d        write (iout,*) 'i=',i
2693         do k=1,3
2694           erij(k)=dc_norm(k,i)
2695         enddo
2696         do j=1,3
2697           do k=1,3
2698             dc_norm(k,i)=erij(k)
2699           enddo
2700           dc_norm(j,i)=dc_norm(j,i)+delta
2701 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2702 !          do k=1,3
2703 !            dc_norm(k,i)=dc_norm(k,i)/fac
2704 !          enddo
2705 !          write (iout,*) (dc_norm(k,i),k=1,3)
2706 !          write (iout,*) (erij(k),k=1,3)
2707           call vec_and_deriv
2708           do k=1,3
2709             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2710             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2711             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2712             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2713           enddo
2714 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2715 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2716 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2717         enddo
2718         do k=1,3
2719           dc_norm(k,i)=erij(k)
2720         enddo
2721 !d        do k=1,3
2722 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2723 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2724 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2725 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2726 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2727 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2728 !d          write (iout,'(a)')
2729 !d        enddo
2730       enddo
2731       return
2732       end subroutine check_vecgrad
2733 !-----------------------------------------------------------------------------
2734       subroutine set_matrices
2735 !      implicit real*8 (a-h,o-z)
2736 !      include 'DIMENSIONS'
2737 #ifdef MPI
2738       include "mpif.h"
2739 !      include "COMMON.SETUP"
2740       integer :: IERR
2741       integer :: status(MPI_STATUS_SIZE)
2742 #endif
2743 !      include 'COMMON.IOUNITS'
2744 !      include 'COMMON.GEO'
2745 !      include 'COMMON.VAR'
2746 !      include 'COMMON.LOCAL'
2747 !      include 'COMMON.CHAIN'
2748 !      include 'COMMON.DERIV'
2749 !      include 'COMMON.INTERACT'
2750 !      include 'COMMON.CONTACTS'
2751 !      include 'COMMON.TORSION'
2752 !      include 'COMMON.VECTORS'
2753 !      include 'COMMON.FFIELD'
2754       real(kind=8) :: auxvec(2),auxmat(2,2)
2755       integer :: i,iti1,iti,k,l
2756       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2,cost1,sint1,&
2757        sint1sq,sint1cub,sint1cost1,b1k,b2k,aux
2758 !       print *,"in set matrices"
2759 !
2760 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2761 ! to calculate the el-loc multibody terms of various order.
2762 !
2763 !AL el      mu=0.0d0
2764
2765 #ifdef PARMAT
2766       do i=ivec_start+2,ivec_end+2
2767 #else
2768       do i=3,nres+1
2769 #endif
2770         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2771           if (itype(i-2,1).eq.0) then
2772           iti = nloctyp
2773           else
2774           iti = itype2loc(itype(i-2,1))
2775           endif
2776         else
2777           iti=nloctyp
2778         endif
2779 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2780         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2781           iti1 = itype2loc(itype(i-1,1))
2782         else
2783           iti1=nloctyp
2784         endif
2785 !        print *,i,itype(i-2,1),iti
2786 #ifdef NEWCORR
2787         cost1=dcos(theta(i-1))
2788         sint1=dsin(theta(i-1))
2789         sint1sq=sint1*sint1
2790         sint1cub=sint1sq*sint1
2791         sint1cost1=2*sint1*cost1
2792 !        print *,"cost1",cost1,theta(i-1)
2793 !c        write (iout,*) "bnew1",i,iti
2794 !c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2795 !c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2796 !c        write (iout,*) "bnew2",i,iti
2797 !c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2798 !c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2799         k=1
2800 !        print *,bnew1(1,k,iti),"bnew1"
2801         do k=1,2
2802           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2803 !          print *,b1k
2804 !          write(*,*) shape(b1)
2805 !          if(.not.allocated(b1)) print *, "WTF?"
2806           b1(k,i-2)=sint1*b1k
2807 !
2808 !             print *,b1(k,i-2)
2809
2810           gtb1(k,i-2)=cost1*b1k-sint1sq*&
2811                    (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2812 !             print *,gtb1(k,i-2)
2813
2814           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2815           b2(k,i-2)=sint1*b2k
2816 !             print *,b2(k,i-2)
2817
2818           gtb2(k,i-2)=cost1*b2k-sint1sq*&
2819                    (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2820 !             print *,gtb2(k,i-2)
2821
2822         enddo
2823 !        print *,b1k,b2k
2824         do k=1,2
2825           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2826           cc(1,k,i-2)=sint1sq*aux
2827           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*&
2828                    (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2829           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2830           dd(1,k,i-2)=sint1sq*aux
2831           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*&
2832                    (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2833         enddo
2834 !        print *,"after cc"
2835         cc(2,1,i-2)=cc(1,2,i-2)
2836         cc(2,2,i-2)=-cc(1,1,i-2)
2837         gtcc(2,1,i-2)=gtcc(1,2,i-2)
2838         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2839         dd(2,1,i-2)=dd(1,2,i-2)
2840         dd(2,2,i-2)=-dd(1,1,i-2)
2841         gtdd(2,1,i-2)=gtdd(1,2,i-2)
2842         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2843 !        print *,"after dd"
2844
2845         do k=1,2
2846           do l=1,2
2847             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2848             EE(l,k,i-2)=sint1sq*aux
2849             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2850           enddo
2851         enddo
2852         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2853         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2854         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2855         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2856         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2857         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2858         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2859 !        print *,"after ee"
2860
2861 !c        b1tilde(1,i-2)=b1(1,i-2)
2862 !c        b1tilde(2,i-2)=-b1(2,i-2)
2863 !c        b2tilde(1,i-2)=b2(1,i-2)
2864 !c        b2tilde(2,i-2)=-b2(2,i-2)
2865 #ifdef DEBUG
2866         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2867         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
2868         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
2869         write (iout,*) 'theta=', theta(i-1)
2870 #endif
2871 #else
2872         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2873 !         write(iout,*) "i,",molnum(i),nloctyp
2874 !         print *, "i,",molnum(i),i,itype(i-2,1)
2875         if (molnum(i).eq.1) then
2876           if (itype(i-2,1).eq.ntyp1) then
2877            iti=nloctyp
2878           else
2879           iti = itype2loc(itype(i-2,1))
2880           endif
2881         else
2882           iti=nloctyp
2883         endif
2884         else
2885           iti=nloctyp
2886         endif
2887 !c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
2888 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2889         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2890           iti1 = itype2loc(itype(i-1,1))
2891         else
2892           iti1=nloctyp
2893         endif
2894 !        print *,i,iti
2895         b1(1,i-2)=b(3,iti)
2896         b1(2,i-2)=b(5,iti)
2897         b2(1,i-2)=b(2,iti)
2898         b2(2,i-2)=b(4,iti)
2899         do k=1,2
2900           do l=1,2
2901            CC(k,l,i-2)=ccold(k,l,iti)
2902            DD(k,l,i-2)=ddold(k,l,iti)
2903            EE(k,l,i-2)=eeold(k,l,iti)
2904           enddo
2905         enddo
2906 #endif
2907         b1tilde(1,i-2)= b1(1,i-2)
2908         b1tilde(2,i-2)=-b1(2,i-2)
2909         b2tilde(1,i-2)= b2(1,i-2)
2910         b2tilde(2,i-2)=-b2(2,i-2)
2911 !c
2912         Ctilde(1,1,i-2)= CC(1,1,i-2)
2913         Ctilde(1,2,i-2)= CC(1,2,i-2)
2914         Ctilde(2,1,i-2)=-CC(2,1,i-2)
2915         Ctilde(2,2,i-2)=-CC(2,2,i-2)
2916 !c
2917         Dtilde(1,1,i-2)= DD(1,1,i-2)
2918         Dtilde(1,2,i-2)= DD(1,2,i-2)
2919         Dtilde(2,1,i-2)=-DD(2,1,i-2)
2920         Dtilde(2,2,i-2)=-DD(2,2,i-2)
2921       enddo
2922 #ifdef PARMAT
2923       do i=ivec_start+2,ivec_end+2
2924 #else
2925       do i=3,nres+1
2926 #endif
2927
2928 !      print *,i,"i"
2929         if (i .lt. nres+1) then
2930           sin1=dsin(phi(i))
2931           cos1=dcos(phi(i))
2932           sintab(i-2)=sin1
2933           costab(i-2)=cos1
2934           obrot(1,i-2)=cos1
2935           obrot(2,i-2)=sin1
2936           sin2=dsin(2*phi(i))
2937           cos2=dcos(2*phi(i))
2938           sintab2(i-2)=sin2
2939           costab2(i-2)=cos2
2940           obrot2(1,i-2)=cos2
2941           obrot2(2,i-2)=sin2
2942           Ug(1,1,i-2)=-cos1
2943           Ug(1,2,i-2)=-sin1
2944           Ug(2,1,i-2)=-sin1
2945           Ug(2,2,i-2)= cos1
2946           Ug2(1,1,i-2)=-cos2
2947           Ug2(1,2,i-2)=-sin2
2948           Ug2(2,1,i-2)=-sin2
2949           Ug2(2,2,i-2)= cos2
2950         else
2951           costab(i-2)=1.0d0
2952           sintab(i-2)=0.0d0
2953           obrot(1,i-2)=1.0d0
2954           obrot(2,i-2)=0.0d0
2955           obrot2(1,i-2)=0.0d0
2956           obrot2(2,i-2)=0.0d0
2957           Ug(1,1,i-2)=1.0d0
2958           Ug(1,2,i-2)=0.0d0
2959           Ug(2,1,i-2)=0.0d0
2960           Ug(2,2,i-2)=1.0d0
2961           Ug2(1,1,i-2)=0.0d0
2962           Ug2(1,2,i-2)=0.0d0
2963           Ug2(2,1,i-2)=0.0d0
2964           Ug2(2,2,i-2)=0.0d0
2965         endif
2966         if (i .gt. 3 .and. i .lt. nres+1) then
2967           obrot_der(1,i-2)=-sin1
2968           obrot_der(2,i-2)= cos1
2969           Ugder(1,1,i-2)= sin1
2970           Ugder(1,2,i-2)=-cos1
2971           Ugder(2,1,i-2)=-cos1
2972           Ugder(2,2,i-2)=-sin1
2973           dwacos2=cos2+cos2
2974           dwasin2=sin2+sin2
2975           obrot2_der(1,i-2)=-dwasin2
2976           obrot2_der(2,i-2)= dwacos2
2977           Ug2der(1,1,i-2)= dwasin2
2978           Ug2der(1,2,i-2)=-dwacos2
2979           Ug2der(2,1,i-2)=-dwacos2
2980           Ug2der(2,2,i-2)=-dwasin2
2981         else
2982           obrot_der(1,i-2)=0.0d0
2983           obrot_der(2,i-2)=0.0d0
2984           Ugder(1,1,i-2)=0.0d0
2985           Ugder(1,2,i-2)=0.0d0
2986           Ugder(2,1,i-2)=0.0d0
2987           Ugder(2,2,i-2)=0.0d0
2988           obrot2_der(1,i-2)=0.0d0
2989           obrot2_der(2,i-2)=0.0d0
2990           Ug2der(1,1,i-2)=0.0d0
2991           Ug2der(1,2,i-2)=0.0d0
2992           Ug2der(2,1,i-2)=0.0d0
2993           Ug2der(2,2,i-2)=0.0d0
2994         endif
2995 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2996         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2997            if (itype(i-2,1).eq.0) then
2998           iti=ntortyp+1
2999            else
3000           iti = itype2loc(itype(i-2,1))
3001            endif
3002         else
3003           iti=nloctyp
3004         endif
3005 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3006         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3007            if (itype(i-1,1).eq.0) then
3008           iti1=nloctyp
3009            else
3010           iti1 = itype2loc(itype(i-1,1))
3011            endif
3012         else
3013           iti1=nloctyp
3014         endif
3015 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
3016 !d        write (iout,*) '*******i',i,' iti1',iti
3017 !        write (iout,*) 'b1',b1(:,iti)
3018 !        write (iout,*) 'b2',b2(:,i-2)
3019 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
3020 !        if (i .gt. iatel_s+2) then
3021         if (i .gt. nnt+2) then
3022           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3023 #ifdef NEWCORR
3024           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3025 !c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3026 #endif
3027
3028           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3029           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3030           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3031           then
3032           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3033           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3034           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3035           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3036           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3037           endif
3038         else
3039           do k=1,2
3040             Ub2(k,i-2)=0.0d0
3041             Ctobr(k,i-2)=0.0d0
3042             Dtobr2(k,i-2)=0.0d0
3043             do l=1,2
3044               EUg(l,k,i-2)=0.0d0
3045               CUg(l,k,i-2)=0.0d0
3046               DUg(l,k,i-2)=0.0d0
3047               DtUg2(l,k,i-2)=0.0d0
3048             enddo
3049           enddo
3050         endif
3051         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3052         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3053         do k=1,2
3054           muder(k,i-2)=Ub2der(k,i-2)
3055         enddo
3056 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3057         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3058           if (itype(i-1,1).eq.0) then
3059            iti1=nloctyp
3060           elseif (itype(i-1,1).le.ntyp) then
3061             iti1 = itype2loc(itype(i-1,1))
3062           else
3063             iti1=nloctyp
3064           endif
3065         else
3066           iti1=nloctyp
3067         endif
3068         do k=1,2
3069           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3070         enddo
3071         if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
3072         if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,i-1)
3073         if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
3074 !d        write (iout,*) 'mu1',mu1(:,i-2)
3075 !d        write (iout,*) 'mu2',mu2(:,i-2)
3076         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3077         then
3078         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3079         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3080         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3081         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3082         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3083 ! Vectors and matrices dependent on a single virtual-bond dihedral.
3084         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3085         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3086         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3087         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3088         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3089         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3090         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3091         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3092         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3093         endif
3094       enddo
3095 ! Matrices dependent on two consecutive virtual-bond dihedrals.
3096 ! The order of matrices is from left to right.
3097       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3098       then
3099 !      do i=max0(ivec_start,2),ivec_end
3100       do i=2,nres-1
3101         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3102         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3103         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3104         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3105         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3106         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3107         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3108         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3109       enddo
3110       endif
3111 #if defined(MPI) && defined(PARMAT)
3112 #ifdef DEBUG
3113 !      if (fg_rank.eq.0) then
3114         write (iout,*) "Arrays UG and UGDER before GATHER"
3115         do i=1,nres-1
3116           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3117            ((ug(l,k,i),l=1,2),k=1,2),&
3118            ((ugder(l,k,i),l=1,2),k=1,2)
3119         enddo
3120         write (iout,*) "Arrays UG2 and UG2DER"
3121         do i=1,nres-1
3122           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3123            ((ug2(l,k,i),l=1,2),k=1,2),&
3124            ((ug2der(l,k,i),l=1,2),k=1,2)
3125         enddo
3126         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3127         do i=1,nres-1
3128           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3129            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3130            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3131         enddo
3132         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3133         do i=1,nres-1
3134           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3135            costab(i),sintab(i),costab2(i),sintab2(i)
3136         enddo
3137         write (iout,*) "Array MUDER"
3138         do i=1,nres-1
3139           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3140         enddo
3141 !      endif
3142 #endif
3143       if (nfgtasks.gt.1) then
3144         time00=MPI_Wtime()
3145 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3146 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3147 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3148 #ifdef MATGATHER
3149         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
3150          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3151          FG_COMM1,IERR)
3152         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
3153          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3154          FG_COMM1,IERR)
3155         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
3156          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3157          FG_COMM1,IERR)
3158         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
3159          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3160          FG_COMM1,IERR)
3161         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
3162          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3163          FG_COMM1,IERR)
3164         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
3165          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3166          FG_COMM1,IERR)
3167         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
3168          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
3169          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3170         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
3171          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
3172          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3173         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
3174          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
3175          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3176         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
3177          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
3178          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3179         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3180         then
3181         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
3182          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3183          FG_COMM1,IERR)
3184         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
3185          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3186          FG_COMM1,IERR)
3187         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
3188          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3189          FG_COMM1,IERR)
3190        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
3191          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3192          FG_COMM1,IERR)
3193         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
3194          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3195          FG_COMM1,IERR)
3196         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
3197          ivec_count(fg_rank1),&
3198          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3199          FG_COMM1,IERR)
3200         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
3201          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3202          FG_COMM1,IERR)
3203         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
3204          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3205          FG_COMM1,IERR)
3206         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
3207          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3208          FG_COMM1,IERR)
3209         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
3210          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3211          FG_COMM1,IERR)
3212         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
3213          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3214          FG_COMM1,IERR)
3215         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
3216          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3217          FG_COMM1,IERR)
3218         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
3219          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3220          FG_COMM1,IERR)
3221         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
3222          ivec_count(fg_rank1),&
3223          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3224          FG_COMM1,IERR)
3225         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
3226          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3227          FG_COMM1,IERR)
3228        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
3229          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3230          FG_COMM1,IERR)
3231         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
3232          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3233          FG_COMM1,IERR)
3234        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
3235          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3236          FG_COMM1,IERR)
3237         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
3238          ivec_count(fg_rank1),&
3239          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3240          FG_COMM1,IERR)
3241         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
3242          ivec_count(fg_rank1),&
3243          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3244          FG_COMM1,IERR)
3245         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
3246          ivec_count(fg_rank1),&
3247          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3248          MPI_MAT2,FG_COMM1,IERR)
3249         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
3250          ivec_count(fg_rank1),&
3251          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3252          MPI_MAT2,FG_COMM1,IERR)
3253         endif
3254 #else
3255 ! Passes matrix info through the ring
3256       isend=fg_rank1
3257       irecv=fg_rank1-1
3258       if (irecv.lt.0) irecv=nfgtasks1-1
3259       iprev=irecv
3260       inext=fg_rank1+1
3261       if (inext.ge.nfgtasks1) inext=0
3262       do i=1,nfgtasks1-1
3263 !        write (iout,*) "isend",isend," irecv",irecv
3264 !        call flush(iout)
3265         lensend=lentyp(isend)
3266         lenrecv=lentyp(irecv)
3267 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3268 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3269 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
3270 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3271 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
3272 !        write (iout,*) "Gather ROTAT1"
3273 !        call flush(iout)
3274 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3275 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
3276 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3277 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
3278 !        write (iout,*) "Gather ROTAT2"
3279 !        call flush(iout)
3280         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
3281          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
3282          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
3283          iprev,4400+irecv,FG_COMM,status,IERR)
3284 !        write (iout,*) "Gather ROTAT_OLD"
3285 !        call flush(iout)
3286         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
3287          MPI_PRECOMP11(lensend),inext,5500+isend,&
3288          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
3289          iprev,5500+irecv,FG_COMM,status,IERR)
3290 !        write (iout,*) "Gather PRECOMP11"
3291 !        call flush(iout)
3292         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
3293          MPI_PRECOMP12(lensend),inext,6600+isend,&
3294          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
3295          iprev,6600+irecv,FG_COMM,status,IERR)
3296 !        write (iout,*) "Gather PRECOMP12"
3297 !        call flush(iout)
3298         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3299         then
3300         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
3301          MPI_ROTAT2(lensend),inext,7700+isend,&
3302          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
3303          iprev,7700+irecv,FG_COMM,status,IERR)
3304 !        write (iout,*) "Gather PRECOMP21"
3305 !        call flush(iout)
3306         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
3307          MPI_PRECOMP22(lensend),inext,8800+isend,&
3308          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
3309          iprev,8800+irecv,FG_COMM,status,IERR)
3310 !        write (iout,*) "Gather PRECOMP22"
3311 !        call flush(iout)
3312         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
3313          MPI_PRECOMP23(lensend),inext,9900+isend,&
3314          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
3315          MPI_PRECOMP23(lenrecv),&
3316          iprev,9900+irecv,FG_COMM,status,IERR)
3317 !        write (iout,*) "Gather PRECOMP23"
3318 !        call flush(iout)
3319         endif
3320         isend=irecv
3321         irecv=irecv-1
3322         if (irecv.lt.0) irecv=nfgtasks1-1
3323       enddo
3324 #endif
3325         time_gather=time_gather+MPI_Wtime()-time00
3326       endif
3327 #ifdef DEBUG
3328 !      if (fg_rank.eq.0) then
3329         write (iout,*) "Arrays UG and UGDER"
3330         do i=1,nres-1
3331           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3332            ((ug(l,k,i),l=1,2),k=1,2),&
3333            ((ugder(l,k,i),l=1,2),k=1,2)
3334         enddo
3335         write (iout,*) "Arrays UG2 and UG2DER"
3336         do i=1,nres-1
3337           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3338            ((ug2(l,k,i),l=1,2),k=1,2),&
3339            ((ug2der(l,k,i),l=1,2),k=1,2)
3340         enddo
3341         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3342         do i=1,nres-1
3343           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3344            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3345            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3346         enddo
3347         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3348         do i=1,nres-1
3349           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3350            costab(i),sintab(i),costab2(i),sintab2(i)
3351         enddo
3352         write (iout,*) "Array MUDER"
3353         do i=1,nres-1
3354           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3355         enddo
3356 !      endif
3357 #endif
3358 #endif
3359 !d      do i=1,nres
3360 !d        iti = itortyp(itype(i,1))
3361 !d        write (iout,*) i
3362 !d        do j=1,2
3363 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3364 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3365 !d        enddo
3366 !d      enddo
3367       return
3368       end subroutine set_matrices
3369 !-----------------------------------------------------------------------------
3370       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3371 !
3372 ! This subroutine calculates the average interaction energy and its gradient
3373 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
3374 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3375 ! The potential depends both on the distance of peptide-group centers and on
3376 ! the orientation of the CA-CA virtual bonds.
3377 !
3378       use comm_locel
3379 !      implicit real*8 (a-h,o-z)
3380 #ifdef MPI
3381       include 'mpif.h'
3382 #endif
3383 !      include 'DIMENSIONS'
3384 !      include 'COMMON.CONTROL'
3385 !      include 'COMMON.SETUP'
3386 !      include 'COMMON.IOUNITS'
3387 !      include 'COMMON.GEO'
3388 !      include 'COMMON.VAR'
3389 !      include 'COMMON.LOCAL'
3390 !      include 'COMMON.CHAIN'
3391 !      include 'COMMON.DERIV'
3392 !      include 'COMMON.INTERACT'
3393 !      include 'COMMON.CONTACTS'
3394 !      include 'COMMON.TORSION'
3395 !      include 'COMMON.VECTORS'
3396 !      include 'COMMON.FFIELD'
3397 !      include 'COMMON.TIME1'
3398       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
3399       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3400       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3401 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3402       real(kind=8),dimension(4) :: muij
3403 !el      integer :: num_conti,j1,j2
3404 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3405 !el        dz_normi,xmedi,ymedi,zmedi
3406
3407 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3408 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3409 !el          num_conti,j1,j2
3410
3411 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3412 #ifdef MOMENT
3413       real(kind=8) :: scal_el=1.0d0
3414 #else
3415       real(kind=8) :: scal_el=0.5d0
3416 #endif
3417 ! 12/13/98
3418 ! 13-go grudnia roku pamietnego...
3419       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3420                                              0.0d0,1.0d0,0.0d0,&
3421                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3422 !el local variables
3423       integer :: i,k,j,icont
3424       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
3425       real(kind=8) :: fac,t_eelecij,fracinbuf
3426
3427
3428 !d      write(iout,*) 'In EELEC'
3429 !        print *,"IN EELEC"
3430 !d      do i=1,nloctyp
3431 !d        write(iout,*) 'Type',i
3432 !d        write(iout,*) 'B1',B1(:,i)
3433 !d        write(iout,*) 'B2',B2(:,i)
3434 !d        write(iout,*) 'CC',CC(:,:,i)
3435 !d        write(iout,*) 'DD',DD(:,:,i)
3436 !d        write(iout,*) 'EE',EE(:,:,i)
3437 !d      enddo
3438 !d      call check_vecgrad
3439 !d      stop
3440 !      ees=0.0d0  !AS
3441 !      evdw1=0.0d0
3442 !      eel_loc=0.0d0
3443 !      eello_turn3=0.0d0
3444 !      eello_turn4=0.0d0
3445       t_eelecij=0.0d0
3446       ees=0.0D0
3447       evdw1=0.0D0
3448       eel_loc=0.0d0
3449       eello_turn3=0.0d0
3450       eello_turn4=0.0d0
3451 !
3452
3453       if (icheckgrad.eq.1) then
3454 !el
3455 !        do i=0,2*nres+2
3456 !          dc_norm(1,i)=0.0d0
3457 !          dc_norm(2,i)=0.0d0
3458 !          dc_norm(3,i)=0.0d0
3459 !        enddo
3460         do i=1,nres-1
3461           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3462           do k=1,3
3463             dc_norm(k,i)=dc(k,i)*fac
3464           enddo
3465 !          write (iout,*) 'i',i,' fac',fac
3466         enddo
3467       endif
3468 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3469 !        wturn6
3470       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3471           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3472           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3473 !        call vec_and_deriv
3474 #ifdef TIMING
3475         time01=MPI_Wtime()
3476 #endif
3477 !        print *, "before set matrices"
3478         call set_matrices
3479 !        print *, "after set matrices"
3480
3481 #ifdef TIMING
3482         time_mat=time_mat+MPI_Wtime()-time01
3483 #endif
3484       endif
3485 !       print *, "after set matrices"
3486 !d      do i=1,nres-1
3487 !d        write (iout,*) 'i=',i
3488 !d        do k=1,3
3489 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3490 !d        enddo
3491 !d        do k=1,3
3492 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3493 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3494 !d        enddo
3495 !d      enddo
3496       t_eelecij=0.0d0
3497       ees=0.0D0
3498       evdw1=0.0D0
3499       eel_loc=0.0d0
3500       eello_turn3=0.0d0
3501       eello_turn4=0.0d0
3502 !el      ind=0
3503       do i=1,nres
3504         num_cont_hb(i)=0
3505       enddo
3506 !d      print '(a)','Enter EELEC'
3507 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3508 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3509 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3510       do i=1,nres
3511         gel_loc_loc(i)=0.0d0
3512         gcorr_loc(i)=0.0d0
3513       enddo
3514 !
3515 !
3516 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3517 !
3518 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3519 !
3520
3521
3522 !        print *,"before iturn3 loop"
3523       do i=iturn3_start,iturn3_end
3524         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3525         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3526         dxi=dc(1,i)
3527         dyi=dc(2,i)
3528         dzi=dc(3,i)
3529         dx_normi=dc_norm(1,i)
3530         dy_normi=dc_norm(2,i)
3531         dz_normi=dc_norm(3,i)
3532         xmedi=c(1,i)+0.5d0*dxi
3533         ymedi=c(2,i)+0.5d0*dyi
3534         zmedi=c(3,i)+0.5d0*dzi
3535         call to_box(xmedi,ymedi,zmedi)
3536         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3537         num_conti=0
3538        call eelecij(i,i+2,ees,evdw1,eel_loc)
3539         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3540         num_cont_hb(i)=num_conti
3541       enddo
3542       do i=iturn4_start,iturn4_end
3543         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3544           .or. itype(i+3,1).eq.ntyp1 &
3545           .or. itype(i+4,1).eq.ntyp1) cycle
3546 !        print *,"before2",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3547         dxi=dc(1,i)
3548         dyi=dc(2,i)
3549         dzi=dc(3,i)
3550         dx_normi=dc_norm(1,i)
3551         dy_normi=dc_norm(2,i)
3552         dz_normi=dc_norm(3,i)
3553         xmedi=c(1,i)+0.5d0*dxi
3554         ymedi=c(2,i)+0.5d0*dyi
3555         zmedi=c(3,i)+0.5d0*dzi
3556         call to_box(xmedi,ymedi,zmedi)
3557         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3558         num_conti=num_cont_hb(i)
3559         call eelecij(i,i+3,ees,evdw1,eel_loc)
3560         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3561         call eturn4(i,eello_turn4)
3562 !        print *,"before",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3563         num_cont_hb(i)=num_conti
3564       enddo   ! i
3565 !
3566 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3567 !
3568 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3569 !      do i=iatel_s,iatel_e
3570 ! JPRDLC
3571        do icont=g_listpp_start,g_listpp_end
3572         i=newcontlistppi(icont)
3573         j=newcontlistppj(icont)
3574         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3575         dxi=dc(1,i)
3576         dyi=dc(2,i)
3577         dzi=dc(3,i)
3578         dx_normi=dc_norm(1,i)
3579         dy_normi=dc_norm(2,i)
3580         dz_normi=dc_norm(3,i)
3581         xmedi=c(1,i)+0.5d0*dxi
3582         ymedi=c(2,i)+0.5d0*dyi
3583         zmedi=c(3,i)+0.5d0*dzi
3584         call to_box(xmedi,ymedi,zmedi)
3585         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3586
3587 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3588         num_conti=num_cont_hb(i)
3589 !        do j=ielstart(i),ielend(i)
3590 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3591           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3592           call eelecij(i,j,ees,evdw1,eel_loc)
3593 !        enddo ! j
3594         num_cont_hb(i)=num_conti
3595       enddo   ! i
3596 !      write (iout,*) "Number of loop steps in EELEC:",ind
3597 !d      do i=1,nres
3598 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3599 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3600 !d      enddo
3601 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3602 !cc      eel_loc=eel_loc+eello_turn3
3603 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3604       return
3605       end subroutine eelec
3606 !-----------------------------------------------------------------------------
3607       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3608
3609       use comm_locel
3610 !      implicit real*8 (a-h,o-z)
3611 !      include 'DIMENSIONS'
3612 #ifdef MPI
3613       include "mpif.h"
3614 #endif
3615 !      include 'COMMON.CONTROL'
3616 !      include 'COMMON.IOUNITS'
3617 !      include 'COMMON.GEO'
3618 !      include 'COMMON.VAR'
3619 !      include 'COMMON.LOCAL'
3620 !      include 'COMMON.CHAIN'
3621 !      include 'COMMON.DERIV'
3622 !      include 'COMMON.INTERACT'
3623 !      include 'COMMON.CONTACTS'
3624 !      include 'COMMON.TORSION'
3625 !      include 'COMMON.VECTORS'
3626 !      include 'COMMON.FFIELD'
3627 !      include 'COMMON.TIME1'
3628       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3629       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3630       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3631 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3632       real(kind=8),dimension(4) :: muij
3633       real(kind=8) :: geel_loc_ij,geel_loc_ji
3634       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3635                     dist_temp, dist_init,rlocshield,fracinbuf
3636       integer xshift,yshift,zshift,ilist,iresshield
3637 !el      integer :: num_conti,j1,j2
3638 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3639 !el        dz_normi,xmedi,ymedi,zmedi
3640
3641 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3642 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3643 !el          num_conti,j1,j2
3644
3645 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3646 #ifdef MOMENT
3647       real(kind=8) :: scal_el=1.0d0
3648 #else
3649       real(kind=8) :: scal_el=0.5d0
3650 #endif
3651 ! 12/13/98
3652 ! 13-go grudnia roku pamietnego...
3653       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3654                                              0.0d0,1.0d0,0.0d0,&
3655                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3656 !      integer :: maxconts=nres/4
3657 !el local variables
3658       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3659       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3660       real(kind=8) ::  faclipij2, faclipij
3661       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3662       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3663                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3664                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3665                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3666                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3667                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3668                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3669                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3670 !      maxconts=nres/4
3671 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3672 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3673
3674 !          time00=MPI_Wtime()
3675 !d      write (iout,*) "eelecij",i,j
3676 !          ind=ind+1
3677           iteli=itel(i)
3678           itelj=itel(j)
3679           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3680           aaa=app(iteli,itelj)
3681           bbb=bpp(iteli,itelj)
3682           ael6i=ael6(iteli,itelj)
3683           ael3i=ael3(iteli,itelj)
3684           dxj=dc(1,j)
3685           dyj=dc(2,j)
3686           dzj=dc(3,j)
3687           dx_normj=dc_norm(1,j)
3688           dy_normj=dc_norm(2,j)
3689           dz_normj=dc_norm(3,j)
3690 !          xj=c(1,j)+0.5D0*dxj-xmedi
3691 !          yj=c(2,j)+0.5D0*dyj-ymedi
3692 !          zj=c(3,j)+0.5D0*dzj-zmedi
3693           xj=c(1,j)+0.5D0*dxj
3694           yj=c(2,j)+0.5D0*dyj
3695           zj=c(3,j)+0.5D0*dzj
3696
3697           call to_box(xj,yj,zj)
3698           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
3699           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
3700           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3701           xj=boxshift(xj-xmedi,boxxsize)
3702           yj=boxshift(yj-ymedi,boxysize)
3703           zj=boxshift(zj-zmedi,boxzsize)
3704
3705           rij=xj*xj+yj*yj+zj*zj
3706           rrmij=1.0D0/rij
3707           rij=dsqrt(rij)
3708 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3709             sss_ele_cut=sscale_ele(rij)
3710             sss_ele_grad=sscagrad_ele(rij)
3711 !             sss_ele_cut=1.0d0
3712 !             sss_ele_grad=0.0d0
3713 !            print *,sss_ele_cut,sss_ele_grad,&
3714 !            (rij),r_cut_ele,rlamb_ele
3715             if (sss_ele_cut.le.0.0) go to 128
3716
3717           rmij=1.0D0/rij
3718           r3ij=rrmij*rmij
3719           r6ij=r3ij*r3ij
3720           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3721           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3722           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3723           fac=cosa-3.0D0*cosb*cosg
3724           ev1=aaa*r6ij*r6ij
3725 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3726           if (j.eq.i+2) ev1=scal_el*ev1
3727           ev2=bbb*r6ij
3728           fac3=ael6i*r6ij
3729           fac4=ael3i*r3ij
3730           evdwij=ev1+ev2
3731           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3732           el2=fac4*fac
3733 !          eesij=el1+el2
3734           if (shield_mode.gt.0) then
3735 !C          fac_shield(i)=0.4
3736 !C          fac_shield(j)=0.6
3737           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3738           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3739           eesij=(el1+el2)
3740           ees=ees+eesij*sss_ele_cut
3741 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3742 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3743           else
3744           fac_shield(i)=1.0
3745           fac_shield(j)=1.0
3746           eesij=(el1+el2)
3747           ees=ees+eesij   &
3748             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3749 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3750           endif
3751
3752 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3753           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3754 !          ees=ees+eesij*sss_ele_cut
3755           evdw1=evdw1+evdwij*sss_ele_cut  &
3756            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3757 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3758 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3759 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3760 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3761
3762           if (energy_dec) then
3763 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3764 !                  'evdw1',i,j,evdwij,&
3765 !                  iteli,itelj,aaa,evdw1
3766               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3767               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3768           endif
3769 !
3770 ! Calculate contributions to the Cartesian gradient.
3771 !
3772 #ifdef SPLITELE
3773           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3774               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3775           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3776              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3777           fac1=fac
3778           erij(1)=xj*rmij
3779           erij(2)=yj*rmij
3780           erij(3)=zj*rmij
3781 !
3782 ! Radial derivatives. First process both termini of the fragment (i,j)
3783 !
3784           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3785           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3786           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3787            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3788           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3789             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3790
3791           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3792           (shield_mode.gt.0)) then
3793 !C          print *,i,j
3794           do ilist=1,ishield_list(i)
3795            iresshield=shield_list(ilist,i)
3796            do k=1,3
3797            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3798            *2.0*sss_ele_cut
3799            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3800                    rlocshield &
3801             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3802             *sss_ele_cut
3803             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3804            enddo
3805           enddo
3806           do ilist=1,ishield_list(j)
3807            iresshield=shield_list(ilist,j)
3808            do k=1,3
3809            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3810           *2.0*sss_ele_cut
3811            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3812                    rlocshield &
3813            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3814            *sss_ele_cut
3815            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3816            enddo
3817           enddo
3818           do k=1,3
3819             gshieldc(k,i)=gshieldc(k,i)+ &
3820                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3821            *sss_ele_cut
3822
3823             gshieldc(k,j)=gshieldc(k,j)+ &
3824                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3825            *sss_ele_cut
3826
3827             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3828                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3829            *sss_ele_cut
3830
3831             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3832                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3833            *sss_ele_cut
3834
3835            enddo
3836            endif
3837
3838
3839 !          do k=1,3
3840 !            ghalf=0.5D0*ggg(k)
3841 !            gelc(k,i)=gelc(k,i)+ghalf
3842 !            gelc(k,j)=gelc(k,j)+ghalf
3843 !          enddo
3844 ! 9/28/08 AL Gradient compotents will be summed only at the end
3845           do k=1,3
3846             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3847             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3848           enddo
3849             gelc_long(3,j)=gelc_long(3,j)+  &
3850           ssgradlipj*eesij/2.0d0*lipscale**2&
3851            *sss_ele_cut
3852
3853             gelc_long(3,i)=gelc_long(3,i)+  &
3854           ssgradlipi*eesij/2.0d0*lipscale**2&
3855            *sss_ele_cut
3856
3857
3858 !
3859 ! Loop over residues i+1 thru j-1.
3860 !
3861 !grad          do k=i+1,j-1
3862 !grad            do l=1,3
3863 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3864 !grad            enddo
3865 !grad          enddo
3866           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3867            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3868           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3869            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3870           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3871            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3872
3873 !          do k=1,3
3874 !            ghalf=0.5D0*ggg(k)
3875 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3876 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3877 !          enddo
3878 ! 9/28/08 AL Gradient compotents will be summed only at the end
3879           do k=1,3
3880             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3881             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3882           enddo
3883
3884 !C Lipidic part for scaling weight
3885            gvdwpp(3,j)=gvdwpp(3,j)+ &
3886           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3887            gvdwpp(3,i)=gvdwpp(3,i)+ &
3888           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3889 !! Loop over residues i+1 thru j-1.
3890 !
3891 !grad          do k=i+1,j-1
3892 !grad            do l=1,3
3893 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3894 !grad            enddo
3895 !grad          enddo
3896 #else
3897           facvdw=(ev1+evdwij)*sss_ele_cut &
3898            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3899
3900           facel=(el1+eesij)*sss_ele_cut
3901           fac1=fac
3902           fac=-3*rrmij*(facvdw+facvdw+facel)
3903           erij(1)=xj*rmij
3904           erij(2)=yj*rmij
3905           erij(3)=zj*rmij
3906 !
3907 ! Radial derivatives. First process both termini of the fragment (i,j)
3908 !
3909           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3910           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3911           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3912 !          do k=1,3
3913 !            ghalf=0.5D0*ggg(k)
3914 !            gelc(k,i)=gelc(k,i)+ghalf
3915 !            gelc(k,j)=gelc(k,j)+ghalf
3916 !          enddo
3917 ! 9/28/08 AL Gradient compotents will be summed only at the end
3918           do k=1,3
3919             gelc_long(k,j)=gelc(k,j)+ggg(k)
3920             gelc_long(k,i)=gelc(k,i)-ggg(k)
3921           enddo
3922 !
3923 ! Loop over residues i+1 thru j-1.
3924 !
3925 !grad          do k=i+1,j-1
3926 !grad            do l=1,3
3927 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3928 !grad            enddo
3929 !grad          enddo
3930 ! 9/28/08 AL Gradient compotents will be summed only at the end
3931           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3932            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3933           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3934            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3935           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3936            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3937
3938           do k=1,3
3939             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3940             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3941           enddo
3942            gvdwpp(3,j)=gvdwpp(3,j)+ &
3943           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3944            gvdwpp(3,i)=gvdwpp(3,i)+ &
3945           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3946
3947 #endif
3948 !
3949 ! Angular part
3950 !
3951           ecosa=2.0D0*fac3*fac1+fac4
3952           fac4=-3.0D0*fac4
3953           fac3=-6.0D0*fac3
3954           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3955           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3956           do k=1,3
3957             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3958             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3959           enddo
3960 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3961 !d   &          (dcosg(k),k=1,3)
3962           do k=1,3
3963             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3964              *fac_shield(i)**2*fac_shield(j)**2 &
3965              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3966
3967           enddo
3968 !          do k=1,3
3969 !            ghalf=0.5D0*ggg(k)
3970 !            gelc(k,i)=gelc(k,i)+ghalf
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 !            gelc(k,j)=gelc(k,j)+ghalf
3974 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3975 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3976 !          enddo
3977 !grad          do k=i+1,j-1
3978 !grad            do l=1,3
3979 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3980 !grad            enddo
3981 !grad          enddo
3982           do k=1,3
3983             gelc(k,i)=gelc(k,i) &
3984                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3985                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3986                      *sss_ele_cut &
3987                      *fac_shield(i)**2*fac_shield(j)**2 &
3988                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3989
3990             gelc(k,j)=gelc(k,j) &
3991                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3992                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3993                      *sss_ele_cut  &
3994                      *fac_shield(i)**2*fac_shield(j)**2  &
3995                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3996
3997             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3998             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3999           enddo
4000
4001           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
4002               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
4003               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4004 !
4005 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4006 !   energy of a peptide unit is assumed in the form of a second-order
4007 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4008 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4009 !   are computed for EVERY pair of non-contiguous peptide groups.
4010 !
4011           if (j.lt.nres-1) then
4012             j1=j+1
4013             j2=j-1
4014           else
4015             j1=j-1
4016             j2=j-2
4017           endif
4018           kkk=0
4019           do k=1,2
4020             do l=1,2
4021               kkk=kkk+1
4022               muij(kkk)=mu(k,i)*mu(l,j)
4023 #ifdef NEWCORR
4024              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4025 !c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4026              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4027              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4028 !c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4029              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4030 #endif
4031
4032             enddo
4033           enddo
4034 !d         write (iout,*) 'EELEC: i',i,' j',j
4035 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
4036 !d          write(iout,*) 'muij',muij
4037           ury=scalar(uy(1,i),erij)
4038           urz=scalar(uz(1,i),erij)
4039           vry=scalar(uy(1,j),erij)
4040           vrz=scalar(uz(1,j),erij)
4041           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4042           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4043           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4044           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4045           fac=dsqrt(-ael6i)*r3ij
4046           a22=a22*fac
4047           a23=a23*fac
4048           a32=a32*fac
4049           a33=a33*fac
4050 !d          write (iout,'(4i5,4f10.5)')
4051 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
4052 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4053 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4054 !d     &      uy(:,j),uz(:,j)
4055 !d          write (iout,'(4f10.5)')
4056 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4057 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4058 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
4059 !d           write (iout,'(9f10.5/)')
4060 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4061 ! Derivatives of the elements of A in virtual-bond vectors
4062           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4063           do k=1,3
4064             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4065             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4066             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4067             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4068             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4069             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4070             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4071             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4072             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4073             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4074             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4075             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4076           enddo
4077 ! Compute radial contributions to the gradient
4078           facr=-3.0d0*rrmij
4079           a22der=a22*facr
4080           a23der=a23*facr
4081           a32der=a32*facr
4082           a33der=a33*facr
4083           agg(1,1)=a22der*xj
4084           agg(2,1)=a22der*yj
4085           agg(3,1)=a22der*zj
4086           agg(1,2)=a23der*xj
4087           agg(2,2)=a23der*yj
4088           agg(3,2)=a23der*zj
4089           agg(1,3)=a32der*xj
4090           agg(2,3)=a32der*yj
4091           agg(3,3)=a32der*zj
4092           agg(1,4)=a33der*xj
4093           agg(2,4)=a33der*yj
4094           agg(3,4)=a33der*zj
4095 ! Add the contributions coming from er
4096           fac3=-3.0d0*fac
4097           do k=1,3
4098             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4099             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4100             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4101             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4102           enddo
4103           do k=1,3
4104 ! Derivatives in DC(i)
4105 !grad            ghalf1=0.5d0*agg(k,1)
4106 !grad            ghalf2=0.5d0*agg(k,2)
4107 !grad            ghalf3=0.5d0*agg(k,3)
4108 !grad            ghalf4=0.5d0*agg(k,4)
4109             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
4110             -3.0d0*uryg(k,2)*vry)!+ghalf1
4111             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
4112             -3.0d0*uryg(k,2)*vrz)!+ghalf2
4113             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
4114             -3.0d0*urzg(k,2)*vry)!+ghalf3
4115             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
4116             -3.0d0*urzg(k,2)*vrz)!+ghalf4
4117 ! Derivatives in DC(i+1)
4118             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
4119             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4120             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
4121             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4122             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
4123             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4124             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
4125             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4126 ! Derivatives in DC(j)
4127             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
4128             -3.0d0*vryg(k,2)*ury)!+ghalf1
4129             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
4130             -3.0d0*vrzg(k,2)*ury)!+ghalf2
4131             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
4132             -3.0d0*vryg(k,2)*urz)!+ghalf3
4133             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
4134             -3.0d0*vrzg(k,2)*urz)!+ghalf4
4135 ! Derivatives in DC(j+1) or DC(nres-1)
4136             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
4137             -3.0d0*vryg(k,3)*ury)
4138             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
4139             -3.0d0*vrzg(k,3)*ury)
4140             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
4141             -3.0d0*vryg(k,3)*urz)
4142             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
4143             -3.0d0*vrzg(k,3)*urz)
4144 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
4145 !grad              do l=1,4
4146 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4147 !grad              enddo
4148 !grad            endif
4149           enddo
4150           acipa(1,1)=a22
4151           acipa(1,2)=a23
4152           acipa(2,1)=a32
4153           acipa(2,2)=a33
4154           a22=-a22
4155           a23=-a23
4156           do l=1,2
4157             do k=1,3
4158               agg(k,l)=-agg(k,l)
4159               aggi(k,l)=-aggi(k,l)
4160               aggi1(k,l)=-aggi1(k,l)
4161               aggj(k,l)=-aggj(k,l)
4162               aggj1(k,l)=-aggj1(k,l)
4163             enddo
4164           enddo
4165           if (j.lt.nres-1) then
4166             a22=-a22
4167             a32=-a32
4168             do l=1,3,2
4169               do k=1,3
4170                 agg(k,l)=-agg(k,l)
4171                 aggi(k,l)=-aggi(k,l)
4172                 aggi1(k,l)=-aggi1(k,l)
4173                 aggj(k,l)=-aggj(k,l)
4174                 aggj1(k,l)=-aggj1(k,l)
4175               enddo
4176             enddo
4177           else
4178             a22=-a22
4179             a23=-a23
4180             a32=-a32
4181             a33=-a33
4182             do l=1,4
4183               do k=1,3
4184                 agg(k,l)=-agg(k,l)
4185                 aggi(k,l)=-aggi(k,l)
4186                 aggi1(k,l)=-aggi1(k,l)
4187                 aggj(k,l)=-aggj(k,l)
4188                 aggj1(k,l)=-aggj1(k,l)
4189               enddo
4190             enddo
4191           endif
4192           ENDIF ! WCORR
4193           IF (wel_loc.gt.0.0d0) THEN
4194 ! Contribution to the local-electrostatic energy coming from the i-j pair
4195           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
4196            +a33*muij(4)
4197           if (shield_mode.eq.0) then
4198            fac_shield(i)=1.0
4199            fac_shield(j)=1.0
4200           endif
4201           eel_loc_ij=eel_loc_ij &
4202          *fac_shield(i)*fac_shield(j) &
4203          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4204 !C Now derivative over eel_loc
4205           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
4206          (shield_mode.gt.0)) then
4207 !C          print *,i,j
4208
4209           do ilist=1,ishield_list(i)
4210            iresshield=shield_list(ilist,i)
4211            do k=1,3
4212            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
4213                                                 /fac_shield(i)&
4214            *sss_ele_cut
4215            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4216                    rlocshield  &
4217           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
4218           *sss_ele_cut
4219
4220             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4221            +rlocshield
4222            enddo
4223           enddo
4224           do ilist=1,ishield_list(j)
4225            iresshield=shield_list(ilist,j)
4226            do k=1,3
4227            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
4228                                             /fac_shield(j)   &
4229             *sss_ele_cut
4230            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4231                    rlocshield  &
4232       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
4233        *sss_ele_cut
4234
4235            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4236                   +rlocshield
4237
4238            enddo
4239           enddo
4240
4241           do k=1,3
4242             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
4243                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4244                     *sss_ele_cut
4245             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
4246                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4247                     *sss_ele_cut
4248             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
4249                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4250                     *sss_ele_cut
4251             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
4252                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4253                     *sss_ele_cut
4254
4255            enddo
4256            endif
4257
4258 #ifdef NEWCORR
4259          geel_loc_ij=(a22*gmuij1(1)&
4260           +a23*gmuij1(2)&
4261           +a32*gmuij1(3)&
4262           +a33*gmuij1(4))&
4263          *fac_shield(i)*fac_shield(j)&
4264                     *sss_ele_cut     &
4265          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4266
4267
4268 !c         write(iout,*) "derivative over thatai"
4269 !c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4270 !c     &   a33*gmuij1(4)
4271          gloc(nphi+i,icg)=gloc(nphi+i,icg)+&
4272            geel_loc_ij*wel_loc
4273 !c         write(iout,*) "derivative over thatai-1"
4274 !c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4275 !c     &   a33*gmuij2(4)
4276          geel_loc_ij=&
4277           a22*gmuij2(1)&
4278           +a23*gmuij2(2)&
4279           +a32*gmuij2(3)&
4280           +a33*gmuij2(4)
4281          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+&
4282            geel_loc_ij*wel_loc&
4283          *fac_shield(i)*fac_shield(j)&
4284                     *sss_ele_cut &
4285          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4286
4287
4288 !c  Derivative over j residue
4289          geel_loc_ji=a22*gmuji1(1)&
4290           +a23*gmuji1(2)&
4291           +a32*gmuji1(3)&
4292           +a33*gmuji1(4)
4293 !c         write(iout,*) "derivative over thataj"
4294 !c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4295 !c     &   a33*gmuji1(4)
4296
4297         gloc(nphi+j,icg)=gloc(nphi+j,icg)+&
4298            geel_loc_ji*wel_loc&
4299          *fac_shield(i)*fac_shield(j)&
4300                     *sss_ele_cut &
4301          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4302
4303
4304          geel_loc_ji=&
4305           +a22*gmuji2(1)&
4306           +a23*gmuji2(2)&
4307           +a32*gmuji2(3)&
4308           +a33*gmuji2(4)
4309 !c         write(iout,*) "derivative over thataj-1"
4310 !c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4311 !c     &   a33*gmuji2(4)
4312          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+&
4313            geel_loc_ji*wel_loc&
4314          *fac_shield(i)*fac_shield(j)&
4315                     *sss_ele_cut &
4316          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4317
4318 #endif
4319
4320 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4321 !           eel_loc_ij=0.0
4322 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4323 !                  'eelloc',i,j,eel_loc_ij
4324           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,8f8.3)') &
4325                   'eelloc',i,j,eel_loc_ij,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4326 !           print *,"EELLOC",i,gel_loc_loc(i-1)
4327
4328 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4329 !          if (energy_dec) write (iout,*) "muij",muij
4330 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
4331
4332           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
4333 ! Partial derivatives in virtual-bond dihedral angles gamma
4334           if (i.gt.1) &
4335           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
4336                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
4337                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
4338                  *sss_ele_cut  &
4339           *fac_shield(i)*fac_shield(j) &
4340           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4341
4342           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
4343                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
4344                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
4345                  *sss_ele_cut &
4346           *fac_shield(i)*fac_shield(j) &
4347           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4348 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4349 !          do l=1,3
4350 !            ggg(1)=(agg(1,1)*muij(1)+ &
4351 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
4352 !            *sss_ele_cut &
4353 !             +eel_loc_ij*sss_ele_grad*rmij*xj
4354 !            ggg(2)=(agg(2,1)*muij(1)+ &
4355 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
4356 !            *sss_ele_cut &
4357 !             +eel_loc_ij*sss_ele_grad*rmij*yj
4358 !            ggg(3)=(agg(3,1)*muij(1)+ &
4359 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
4360 !            *sss_ele_cut &
4361 !             +eel_loc_ij*sss_ele_grad*rmij*zj
4362            xtemp(1)=xj
4363            xtemp(2)=yj
4364            xtemp(3)=zj
4365
4366            do l=1,3
4367             ggg(l)=(agg(l,1)*muij(1)+ &
4368                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
4369             *sss_ele_cut &
4370           *fac_shield(i)*fac_shield(j) &
4371           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
4372              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4373
4374
4375             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4376             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4377 !grad            ghalf=0.5d0*ggg(l)
4378 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4379 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4380           enddo
4381             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
4382           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
4383           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4384
4385             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
4386           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
4387           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4388
4389 !grad          do k=i+1,j2
4390 !grad            do l=1,3
4391 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4392 !grad            enddo
4393 !grad          enddo
4394 ! Remaining derivatives of eello
4395           do l=1,3
4396             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4397                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
4398             *sss_ele_cut &
4399           *fac_shield(i)*fac_shield(j) &
4400           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4401
4402 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4403             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4404                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4405             +aggi1(l,4)*muij(4))&
4406             *sss_ele_cut &
4407           *fac_shield(i)*fac_shield(j) &
4408           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4409
4410 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4411             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4412                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4413             *sss_ele_cut &
4414           *fac_shield(i)*fac_shield(j) &
4415           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4416
4417 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4418             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4419                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4420             +aggj1(l,4)*muij(4))&
4421             *sss_ele_cut &
4422           *fac_shield(i)*fac_shield(j) &
4423          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4424
4425 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4426           enddo
4427           ENDIF
4428 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4429 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4430           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4431              .and. num_conti.le.maxconts) then
4432 !            write (iout,*) i,j," entered corr"
4433 !
4434 ! Calculate the contact function. The ith column of the array JCONT will
4435 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4436 ! greater than I). The arrays FACONT and GACONT will contain the values of
4437 ! the contact function and its derivative.
4438 !           r0ij=1.02D0*rpp(iteli,itelj)
4439 !           r0ij=1.11D0*rpp(iteli,itelj)
4440             r0ij=2.20D0*rpp(iteli,itelj)
4441 !           r0ij=1.55D0*rpp(iteli,itelj)
4442             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4443 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4444             if (fcont.gt.0.0D0) then
4445               num_conti=num_conti+1
4446               if (num_conti.gt.maxconts) then
4447 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4448 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4449                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4450                                ' will skip next contacts for this conf.', num_conti
4451               else
4452                 jcont_hb(num_conti,i)=j
4453 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4454 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4455                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4456                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4457 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4458 !  terms.
4459                 d_cont(num_conti,i)=rij
4460 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4461 !     --- Electrostatic-interaction matrix ---
4462                 a_chuj(1,1,num_conti,i)=a22
4463                 a_chuj(1,2,num_conti,i)=a23
4464                 a_chuj(2,1,num_conti,i)=a32
4465                 a_chuj(2,2,num_conti,i)=a33
4466 !     --- Gradient of rij
4467                 do kkk=1,3
4468                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4469                 enddo
4470                 kkll=0
4471                 do k=1,2
4472                   do l=1,2
4473                     kkll=kkll+1
4474                     do m=1,3
4475                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4476                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4477                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4478                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4479                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4480                     enddo
4481                   enddo
4482                 enddo
4483                 ENDIF
4484                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4485 ! Calculate contact energies
4486                 cosa4=4.0D0*cosa
4487                 wij=cosa-3.0D0*cosb*cosg
4488                 cosbg1=cosb+cosg
4489                 cosbg2=cosb-cosg
4490 !               fac3=dsqrt(-ael6i)/r0ij**3
4491                 fac3=dsqrt(-ael6i)*r3ij
4492 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4493                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4494                 if (ees0tmp.gt.0) then
4495                   ees0pij=dsqrt(ees0tmp)
4496                 else
4497                   ees0pij=0
4498                 endif
4499                 if (shield_mode.eq.0) then
4500                 fac_shield(i)=1.0d0
4501                 fac_shield(j)=1.0d0
4502                 else
4503                 ees0plist(num_conti,i)=j
4504                 endif
4505 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4506                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4507                 if (ees0tmp.gt.0) then
4508                   ees0mij=dsqrt(ees0tmp)
4509                 else
4510                   ees0mij=0
4511                 endif
4512 !               ees0mij=0.0D0
4513                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4514                      *sss_ele_cut &
4515                      *fac_shield(i)*fac_shield(j)
4516 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4517
4518                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4519                      *sss_ele_cut &
4520                      *fac_shield(i)*fac_shield(j)
4521 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4522
4523 ! Diagnostics. Comment out or remove after debugging!
4524 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4525 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4526 !               ees0m(num_conti,i)=0.0D0
4527 ! End diagnostics.
4528 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4529 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4530 ! Angular derivatives of the contact function
4531                 ees0pij1=fac3/ees0pij
4532                 ees0mij1=fac3/ees0mij
4533                 fac3p=-3.0D0*fac3*rrmij
4534                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4535                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4536 !               ees0mij1=0.0D0
4537                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4538                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4539                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4540                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4541                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4542                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4543                 ecosap=ecosa1+ecosa2
4544                 ecosbp=ecosb1+ecosb2
4545                 ecosgp=ecosg1+ecosg2
4546                 ecosam=ecosa1-ecosa2
4547                 ecosbm=ecosb1-ecosb2
4548                 ecosgm=ecosg1-ecosg2
4549 ! Diagnostics
4550 !               ecosap=ecosa1
4551 !               ecosbp=ecosb1
4552 !               ecosgp=ecosg1
4553 !               ecosam=0.0D0
4554 !               ecosbm=0.0D0
4555 !               ecosgm=0.0D0
4556 ! End diagnostics
4557                 facont_hb(num_conti,i)=fcont
4558                 fprimcont=fprimcont/rij
4559 !d              facont_hb(num_conti,i)=1.0D0
4560 ! Following line is for diagnostics.
4561 !d              fprimcont=0.0D0
4562                 do k=1,3
4563                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4564                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4565                 enddo
4566                 do k=1,3
4567                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4568                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4569                 enddo
4570                 gggp(1)=gggp(1)+ees0pijp*xj &
4571                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4572                 gggp(2)=gggp(2)+ees0pijp*yj &
4573                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4574                 gggp(3)=gggp(3)+ees0pijp*zj &
4575                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4576
4577                 gggm(1)=gggm(1)+ees0mijp*xj &
4578                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4579
4580                 gggm(2)=gggm(2)+ees0mijp*yj &
4581                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4582
4583                 gggm(3)=gggm(3)+ees0mijp*zj &
4584                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4585
4586 ! Derivatives due to the contact function
4587                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4588                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4589                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4590                 do k=1,3
4591 !
4592 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4593 !          following the change of gradient-summation algorithm.
4594 !
4595 !grad                  ghalfp=0.5D0*gggp(k)
4596 !grad                  ghalfm=0.5D0*gggm(k)
4597                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4598                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4599                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4600                      *sss_ele_cut*fac_shield(i)*fac_shield(j) ! &
4601 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4602
4603
4604                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4605                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4606                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4607                      *sss_ele_cut*fac_shield(i)*fac_shield(j)!   &
4608 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4609
4610
4611                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4612                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4613 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4614
4615                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4616                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4617                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4618                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4619 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4620
4621                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4622                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4623                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4624                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4625 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4626
4627                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4628                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4629 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4630
4631                 enddo
4632 ! Diagnostics. Comment out or remove after debugging!
4633 !diag           do k=1,3
4634 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4635 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4636 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4637 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4638 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4639 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4640 !diag           enddo
4641               ENDIF ! wcorr
4642               endif  ! num_conti.le.maxconts
4643             endif  ! fcont.gt.0
4644           endif    ! j.gt.i+1
4645           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4646             do k=1,4
4647               do l=1,3
4648                 ghalf=0.5d0*agg(l,k)
4649                 aggi(l,k)=aggi(l,k)+ghalf
4650                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4651                 aggj(l,k)=aggj(l,k)+ghalf
4652               enddo
4653             enddo
4654             if (j.eq.nres-1 .and. i.lt.j-2) then
4655               do k=1,4
4656                 do l=1,3
4657                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4658                 enddo
4659               enddo
4660             endif
4661           endif
4662  128  continue
4663 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4664       return
4665       end subroutine eelecij
4666 !-----------------------------------------------------------------------------
4667       subroutine eturn3(i,eello_turn3)
4668 ! Third- and fourth-order contributions from turns
4669
4670       use comm_locel
4671 !      implicit real*8 (a-h,o-z)
4672 !      include 'DIMENSIONS'
4673 !      include 'COMMON.IOUNITS'
4674 !      include 'COMMON.GEO'
4675 !      include 'COMMON.VAR'
4676 !      include 'COMMON.LOCAL'
4677 !      include 'COMMON.CHAIN'
4678 !      include 'COMMON.DERIV'
4679 !      include 'COMMON.INTERACT'
4680 !      include 'COMMON.CONTACTS'
4681 !      include 'COMMON.TORSION'
4682 !      include 'COMMON.VECTORS'
4683 !      include 'COMMON.FFIELD'
4684 !      include 'COMMON.CONTROL'
4685       real(kind=8),dimension(3) :: ggg
4686       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4687         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,gpizda1,&
4688        gpizda2,auxgmat1,auxgmatt1,auxgmat2,auxgmatt2
4689
4690       real(kind=8),dimension(2) :: auxvec,auxvec1
4691 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4692       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4693 !el      integer :: num_conti,j1,j2
4694 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4695 !el        dz_normi,xmedi,ymedi,zmedi
4696
4697 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4698 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4699 !el         num_conti,j1,j2
4700 !el local variables
4701       integer :: i,j,l,k,ilist,iresshield
4702       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield,xj,yj
4703       xj=0.0d0
4704       yj=0.0d0
4705       j=i+2
4706 !      write (iout,*) "eturn3",i,j,j1,j2
4707           zj=(c(3,j)+c(3,j+1))/2.0d0
4708             call to_box(xj,yj,zj)
4709             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
4710
4711       a_temp(1,1)=a22
4712       a_temp(1,2)=a23
4713       a_temp(2,1)=a32
4714       a_temp(2,2)=a33
4715 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4716 !
4717 !               Third-order contributions
4718 !
4719 !                 (i+2)o----(i+3)
4720 !                      | |
4721 !                      | |
4722 !                 (i+1)o----i
4723 !
4724 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4725 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4726         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4727         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4728         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4729         call transpose2(auxmat(1,1),auxmat1(1,1))
4730         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4731         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4732         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4733         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4734         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4735
4736         if (shield_mode.eq.0) then
4737         fac_shield(i)=1.0d0
4738         fac_shield(j)=1.0d0
4739         endif
4740
4741         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4742          *fac_shield(i)*fac_shield(j)  &
4743          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4744         eello_t3= &
4745         0.5d0*(pizda(1,1)+pizda(2,2)) &
4746         *fac_shield(i)*fac_shield(j)
4747
4748         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4749                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4750 !C#ifdef NEWCORR
4751 !C Derivatives in theta
4752         gloc(nphi+i,icg)=gloc(nphi+i,icg) &
4753        +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3&
4754         *fac_shield(i)*fac_shield(j) &
4755         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4756
4757         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)&
4758        +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3&
4759         *fac_shield(i)*fac_shield(j) &
4760         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4761
4762
4763 !C#endif
4764
4765
4766
4767           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4768        (shield_mode.gt.0)) then
4769 !C          print *,i,j
4770
4771           do ilist=1,ishield_list(i)
4772            iresshield=shield_list(ilist,i)
4773            do k=1,3
4774            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4775            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4776                    rlocshield &
4777            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4778             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4779              +rlocshield
4780            enddo
4781           enddo
4782           do ilist=1,ishield_list(j)
4783            iresshield=shield_list(ilist,j)
4784            do k=1,3
4785            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4786            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4787                    rlocshield &
4788            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4789            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4790                   +rlocshield
4791
4792            enddo
4793           enddo
4794
4795           do k=1,3
4796             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4797                    grad_shield(k,i)*eello_t3/fac_shield(i)
4798             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4799                    grad_shield(k,j)*eello_t3/fac_shield(j)
4800             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4801                    grad_shield(k,i)*eello_t3/fac_shield(i)
4802             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4803                    grad_shield(k,j)*eello_t3/fac_shield(j)
4804            enddo
4805            endif
4806
4807 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4808 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4809 !d     &    ' eello_turn3_num',4*eello_turn3_num
4810 ! Derivatives in gamma(i)
4811         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4812         call transpose2(auxmat2(1,1),auxmat3(1,1))
4813         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4814         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4815           *fac_shield(i)*fac_shield(j)        &
4816           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4817 ! Derivatives in gamma(i+1)
4818         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4819         call transpose2(auxmat2(1,1),auxmat3(1,1))
4820         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4821         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4822           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4823           *fac_shield(i)*fac_shield(j)        &
4824           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4825
4826 ! Cartesian derivatives
4827         do l=1,3
4828 !            ghalf1=0.5d0*agg(l,1)
4829 !            ghalf2=0.5d0*agg(l,2)
4830 !            ghalf3=0.5d0*agg(l,3)
4831 !            ghalf4=0.5d0*agg(l,4)
4832           a_temp(1,1)=aggi(l,1)!+ghalf1
4833           a_temp(1,2)=aggi(l,2)!+ghalf2
4834           a_temp(2,1)=aggi(l,3)!+ghalf3
4835           a_temp(2,2)=aggi(l,4)!+ghalf4
4836           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4837           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4838             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4839           *fac_shield(i)*fac_shield(j)      &
4840           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4841
4842           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4843           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4844           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4845           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4846           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4847           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4848             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4849           *fac_shield(i)*fac_shield(j)        &
4850           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4851
4852           a_temp(1,1)=aggj(l,1)!+ghalf1
4853           a_temp(1,2)=aggj(l,2)!+ghalf2
4854           a_temp(2,1)=aggj(l,3)!+ghalf3
4855           a_temp(2,2)=aggj(l,4)!+ghalf4
4856           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4857           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4858             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4859           *fac_shield(i)*fac_shield(j)      &
4860           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4861
4862           a_temp(1,1)=aggj1(l,1)
4863           a_temp(1,2)=aggj1(l,2)
4864           a_temp(2,1)=aggj1(l,3)
4865           a_temp(2,2)=aggj1(l,4)
4866           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4867           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4868             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4869           *fac_shield(i)*fac_shield(j)        &
4870           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4871         enddo
4872          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4873           ssgradlipi*eello_t3/4.0d0*lipscale
4874          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4875           ssgradlipj*eello_t3/4.0d0*lipscale
4876          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4877           ssgradlipi*eello_t3/4.0d0*lipscale
4878          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4879           ssgradlipj*eello_t3/4.0d0*lipscale
4880
4881       return
4882       end subroutine eturn3
4883 !-----------------------------------------------------------------------------
4884       subroutine eturn4(i,eello_turn4)
4885 ! Third- and fourth-order contributions from turns
4886
4887       use comm_locel
4888 !      implicit real*8 (a-h,o-z)
4889 !      include 'DIMENSIONS'
4890 !      include 'COMMON.IOUNITS'
4891 !      include 'COMMON.GEO'
4892 !      include 'COMMON.VAR'
4893 !      include 'COMMON.LOCAL'
4894 !      include 'COMMON.CHAIN'
4895 !      include 'COMMON.DERIV'
4896 !      include 'COMMON.INTERACT'
4897 !      include 'COMMON.CONTACTS'
4898 !      include 'COMMON.TORSION'
4899 !      include 'COMMON.VECTORS'
4900 !      include 'COMMON.FFIELD'
4901 !      include 'COMMON.CONTROL'
4902       real(kind=8),dimension(3) :: ggg
4903       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4904         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,&
4905         gte1t,gte2t,gte3t,&
4906         gte1a,gtae3,gtae3e2, ae3gte2,&
4907         gtEpizda1,gtEpizda2,gtEpizda3
4908
4909       real(kind=8),dimension(2) :: auxvec,auxvec1,auxgEvec1,auxgEvec2,&
4910        auxgEvec3,auxgvec
4911
4912 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4913       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4914 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4915 !el        dz_normi,xmedi,ymedi,zmedi
4916 !el      integer :: num_conti,j1,j2
4917 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4918 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4919 !el          num_conti,j1,j2
4920 !el local variables
4921       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4922       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4923          rlocshield,gs23,gs32,gsE13,gs13,gs21,gsE31,gsEE1,gsEE2,gsEE3,xj,yj
4924       xj=0.0d0
4925       yj=0.0d0
4926       j=i+3
4927 !      if (j.ne.20) return
4928 !      print *,i,j,gshieldc_t4(2,j),gshieldc_t4(2,j+1)
4929 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4930 !
4931 !               Fourth-order contributions
4932 !
4933 !                 (i+3)o----(i+4)
4934 !                     /  |
4935 !               (i+2)o   |
4936 !                     \  |
4937 !                 (i+1)o----i
4938 !
4939 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4940 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4941 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4942           zj=(c(3,j)+c(3,j+1))/2.0d0
4943             call to_box(xj,yj,zj)
4944             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
4945
4946
4947         a_temp(1,1)=a22
4948         a_temp(1,2)=a23
4949         a_temp(2,1)=a32
4950         a_temp(2,2)=a33
4951         iti1=i+1
4952         iti2=i+2
4953         iti3=i+3
4954 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4955         call transpose2(EUg(1,1,i+1),e1t(1,1))
4956         call transpose2(Eug(1,1,i+2),e2t(1,1))
4957         call transpose2(Eug(1,1,i+3),e3t(1,1))
4958 !C Ematrix derivative in theta
4959         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4960         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4961         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4962
4963         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4964         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4965         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4966         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4967 !c       auxalary matrix of E i+1
4968         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4969         s1=scalar2(b1(1,iti2),auxvec(1))
4970 !c derivative of theta i+2 with constant i+3
4971         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4972 !c derivative of theta i+2 with constant i+2
4973         gs32=scalar2(b1(1,i+2),auxgvec(1))
4974 !c derivative of E matix in theta of i+1
4975         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4976
4977         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4978         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4979         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4980 !c auxilary matrix auxgvec of Ub2 with constant E matirx
4981         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4982 !c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4983         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4984         s2=scalar2(b1(1,i+1),auxvec(1))
4985 !c derivative of theta i+1 with constant i+3
4986         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4987 !c derivative of theta i+2 with constant i+1
4988         gs21=scalar2(b1(1,i+1),auxgvec(1))
4989 !c derivative of theta i+3 with constant i+1
4990         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4991
4992         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4993         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4994 !c ae3gte2 is derivative over i+2
4995         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4996
4997         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4998         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4999 !c i+2
5000         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5001 !c i+3
5002         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5003
5004         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5005         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5006         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5007         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5008         if (shield_mode.eq.0) then
5009         fac_shield(i)=1.0
5010         fac_shield(j)=1.0
5011         endif
5012
5013         eello_turn4=eello_turn4-(s1+s2+s3) &
5014         *fac_shield(i)*fac_shield(j)       &
5015         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5016         eello_t4=-(s1+s2+s3)  &
5017           *fac_shield(i)*fac_shield(j)
5018 !C Now derivative over shield:
5019           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
5020          (shield_mode.gt.0)) then
5021 !C          print *,i,j
5022
5023           do ilist=1,ishield_list(i)
5024            iresshield=shield_list(ilist,i)
5025            do k=1,3
5026            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5027 !           print *,"rlocshield",rlocshield,grad_shield_side(k,ilist,i),iresshield
5028            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5029                    rlocshield &
5030             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5031             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5032            +rlocshield
5033            enddo
5034           enddo
5035           do ilist=1,ishield_list(j)
5036            iresshield=shield_list(ilist,j)
5037            do k=1,3
5038 !           print *,"rlocshieldj",j,rlocshield,grad_shield_side(k,ilist,j),iresshield
5039            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5040            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5041                    rlocshield  &
5042            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5043            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5044                   +rlocshield
5045 !            print *,"after", gshieldc_t4(k,iresshield-1),iresshield-1,gshieldc_t4(k,iresshield)
5046
5047            enddo
5048           enddo
5049           do k=1,3
5050             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
5051                    grad_shield(k,i)*eello_t4/fac_shield(i)
5052             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
5053                    grad_shield(k,j)*eello_t4/fac_shield(j)
5054             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
5055                    grad_shield(k,i)*eello_t4/fac_shield(i)
5056             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
5057                    grad_shield(k,j)*eello_t4/fac_shield(j)
5058 !           print *,"gshieldc_t4(k,j+1)",j,gshieldc_t4(k,j+1)
5059            enddo
5060            endif
5061 #ifdef NEWCORR
5062         gloc(nphi+i,icg)=gloc(nphi+i,icg)&
5063                        -(gs13+gsE13+gsEE1)*wturn4&
5064        *fac_shield(i)*fac_shield(j)
5065         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)&
5066                          -(gs23+gs21+gsEE2)*wturn4&
5067        *fac_shield(i)*fac_shield(j)
5068
5069         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)&
5070                          -(gs32+gsE31+gsEE3)*wturn4&
5071        *fac_shield(i)*fac_shield(j)
5072
5073 !c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5074 !c     &   gs2
5075 #endif
5076         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5077            'eturn4',i,j,-(s1+s2+s3)
5078 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5079 !d     &    ' eello_turn4_num',8*eello_turn4_num
5080 ! Derivatives in gamma(i)
5081         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5082         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5083         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5084         s1=scalar2(b1(1,i+1),auxvec(1))
5085         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5086         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5087         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
5088        *fac_shield(i)*fac_shield(j)  &
5089        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5090
5091 ! Derivatives in gamma(i+1)
5092         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5093         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5094         s2=scalar2(b1(1,iti1),auxvec(1))
5095         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5096         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5097         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5098         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
5099        *fac_shield(i)*fac_shield(j)  &
5100        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5101
5102 ! Derivatives in gamma(i+2)
5103         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5104         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5105         s1=scalar2(b1(1,iti2),auxvec(1))
5106         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5107         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5108         s2=scalar2(b1(1,iti1),auxvec(1))
5109         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5110         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5111         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5112         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
5113        *fac_shield(i)*fac_shield(j)  &
5114        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5115
5116 ! Cartesian derivatives
5117 ! Derivatives of this turn contributions in DC(i+2)
5118         if (j.lt.nres-1) then
5119           do l=1,3
5120             a_temp(1,1)=agg(l,1)
5121             a_temp(1,2)=agg(l,2)
5122             a_temp(2,1)=agg(l,3)
5123             a_temp(2,2)=agg(l,4)
5124             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5125             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5126             s1=scalar2(b1(1,iti2),auxvec(1))
5127             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5128             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5129             s2=scalar2(b1(1,iti1),auxvec(1))
5130             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5131             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5132             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5133             ggg(l)=-(s1+s2+s3)
5134             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
5135        *fac_shield(i)*fac_shield(j)  &
5136        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5137
5138           enddo
5139         endif
5140 ! Remaining derivatives of this turn contribution
5141         do l=1,3
5142           a_temp(1,1)=aggi(l,1)
5143           a_temp(1,2)=aggi(l,2)
5144           a_temp(2,1)=aggi(l,3)
5145           a_temp(2,2)=aggi(l,4)
5146           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5147           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5148           s1=scalar2(b1(1,iti2),auxvec(1))
5149           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5150           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5151           s2=scalar2(b1(1,iti1),auxvec(1))
5152           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5153           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5154           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5155           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
5156          *fac_shield(i)*fac_shield(j)  &
5157          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5158
5159
5160           a_temp(1,1)=aggi1(l,1)
5161           a_temp(1,2)=aggi1(l,2)
5162           a_temp(2,1)=aggi1(l,3)
5163           a_temp(2,2)=aggi1(l,4)
5164           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5165           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5166           s1=scalar2(b1(1,iti2),auxvec(1))
5167           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5168           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5169           s2=scalar2(b1(1,iti1),auxvec(1))
5170           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5171           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5172           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5173           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
5174          *fac_shield(i)*fac_shield(j)  &
5175          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5176
5177
5178           a_temp(1,1)=aggj(l,1)
5179           a_temp(1,2)=aggj(l,2)
5180           a_temp(2,1)=aggj(l,3)
5181           a_temp(2,2)=aggj(l,4)
5182           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5183           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5184           s1=scalar2(b1(1,iti2),auxvec(1))
5185           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5186           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5187           s2=scalar2(b1(1,iti1),auxvec(1))
5188           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5189           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5190           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5191 !        if (j.lt.nres-1) then
5192           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
5193          *fac_shield(i)*fac_shield(j)  &
5194          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5195 !        endif
5196
5197           a_temp(1,1)=aggj1(l,1)
5198           a_temp(1,2)=aggj1(l,2)
5199           a_temp(2,1)=aggj1(l,3)
5200           a_temp(2,2)=aggj1(l,4)
5201           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5202           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5203           s1=scalar2(b1(1,iti2),auxvec(1))
5204           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5205           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5206           s2=scalar2(b1(1,iti1),auxvec(1))
5207           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5208           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5209           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5210 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5211 !        if (j.lt.nres-1) then
5212 !          print *,"juest before",j1, gcorr4_turn(l,j1)
5213           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
5214          *fac_shield(i)*fac_shield(j)  &
5215          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5216 !            if (shield_mode.gt.0) then
5217 !             print *,"juest after",j1, gcorr4_turn(l,j1),gshieldc_t4(k,j1),gshieldc_loc_t4(k,j1),gel_loc_turn4(i+2)
5218 !            else
5219 !             print *,"juest after",j1, gcorr4_turn(l,j1),gel_loc_turn4(i+2)
5220 !            endif
5221 !         endif
5222         enddo
5223          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
5224           ssgradlipi*eello_t4/4.0d0*lipscale
5225          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
5226           ssgradlipj*eello_t4/4.0d0*lipscale
5227          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
5228           ssgradlipi*eello_t4/4.0d0*lipscale
5229          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
5230           ssgradlipj*eello_t4/4.0d0*lipscale
5231
5232       return
5233       end subroutine eturn4
5234 !-----------------------------------------------------------------------------
5235       subroutine unormderiv(u,ugrad,unorm,ungrad)
5236 ! This subroutine computes the derivatives of a normalized vector u, given
5237 ! the derivatives computed without normalization conditions, ugrad. Returns
5238 ! ungrad.
5239 !      implicit none
5240       real(kind=8),dimension(3) :: u,vec
5241       real(kind=8),dimension(3,3) ::ugrad,ungrad
5242       real(kind=8) :: unorm      !,scalar
5243       integer :: i,j
5244 !      write (2,*) 'ugrad',ugrad
5245 !      write (2,*) 'u',u
5246       do i=1,3
5247         vec(i)=scalar(ugrad(1,i),u(1))
5248       enddo
5249 !      write (2,*) 'vec',vec
5250       do i=1,3
5251         do j=1,3
5252           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5253         enddo
5254       enddo
5255 !      write (2,*) 'ungrad',ungrad
5256       return
5257       end subroutine unormderiv
5258 !-----------------------------------------------------------------------------
5259       subroutine escp_soft_sphere(evdw2,evdw2_14)
5260 !
5261 ! This subroutine calculates the excluded-volume interaction energy between
5262 ! peptide-group centers and side chains and its gradient in virtual-bond and
5263 ! side-chain vectors.
5264 !
5265 !      implicit real*8 (a-h,o-z)
5266 !      include 'DIMENSIONS'
5267 !      include 'COMMON.GEO'
5268 !      include 'COMMON.VAR'
5269 !      include 'COMMON.LOCAL'
5270 !      include 'COMMON.CHAIN'
5271 !      include 'COMMON.DERIV'
5272 !      include 'COMMON.INTERACT'
5273 !      include 'COMMON.FFIELD'
5274 !      include 'COMMON.IOUNITS'
5275 !      include 'COMMON.CONTROL'
5276       real(kind=8),dimension(3) :: ggg
5277 !el local variables
5278       integer :: i,iint,j,k,iteli,itypj
5279       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
5280                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
5281
5282       evdw2=0.0D0
5283       evdw2_14=0.0d0
5284       r0_scp=4.5d0
5285 !d    print '(a)','Enter ESCP'
5286 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5287       do i=iatscp_s,iatscp_e
5288         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5289         iteli=itel(i)
5290         xi=0.5D0*(c(1,i)+c(1,i+1))
5291         yi=0.5D0*(c(2,i)+c(2,i+1))
5292         zi=0.5D0*(c(3,i)+c(3,i+1))
5293           call to_box(xi,yi,zi)
5294
5295         do iint=1,nscp_gr(i)
5296
5297         do j=iscpstart(i,iint),iscpend(i,iint)
5298           if (itype(j,1).eq.ntyp1) cycle
5299           itypj=iabs(itype(j,1))
5300 ! Uncomment following three lines for SC-p interactions
5301 !         xj=c(1,nres+j)-xi
5302 !         yj=c(2,nres+j)-yi
5303 !         zj=c(3,nres+j)-zi
5304 ! Uncomment following three lines for Ca-p interactions
5305           xj=c(1,j)-xi
5306           yj=c(2,j)-yi
5307           zj=c(3,j)-zi
5308           call to_box(xj,yj,zj)
5309           xj=boxshift(xj-xi,boxxsize)
5310           yj=boxshift(yj-yi,boxysize)
5311           zj=boxshift(zj-zi,boxzsize)
5312           rij=xj*xj+yj*yj+zj*zj
5313           r0ij=r0_scp
5314           r0ijsq=r0ij*r0ij
5315           if (rij.lt.r0ijsq) then
5316             evdwij=0.25d0*(rij-r0ijsq)**2
5317             fac=rij-r0ijsq
5318           else
5319             evdwij=0.0d0
5320             fac=0.0d0
5321           endif
5322           evdw2=evdw2+evdwij
5323 !
5324 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5325 !
5326           ggg(1)=xj*fac
5327           ggg(2)=yj*fac
5328           ggg(3)=zj*fac
5329 !grad          if (j.lt.i) then
5330 !d          write (iout,*) 'j<i'
5331 ! Uncomment following three lines for SC-p interactions
5332 !           do k=1,3
5333 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5334 !           enddo
5335 !grad          else
5336 !d          write (iout,*) 'j>i'
5337 !grad            do k=1,3
5338 !grad              ggg(k)=-ggg(k)
5339 ! Uncomment following line for SC-p interactions
5340 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5341 !grad            enddo
5342 !grad          endif
5343 !grad          do k=1,3
5344 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5345 !grad          enddo
5346 !grad          kstart=min0(i+1,j)
5347 !grad          kend=max0(i-1,j-1)
5348 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5349 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5350 !grad          do k=kstart,kend
5351 !grad            do l=1,3
5352 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5353 !grad            enddo
5354 !grad          enddo
5355           do k=1,3
5356             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5357             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5358           enddo
5359         enddo
5360
5361         enddo ! iint
5362       enddo ! i
5363       return
5364       end subroutine escp_soft_sphere
5365 !-----------------------------------------------------------------------------
5366       subroutine escp(evdw2,evdw2_14)
5367 !
5368 ! This subroutine calculates the excluded-volume interaction energy between
5369 ! peptide-group centers and side chains and its gradient in virtual-bond and
5370 ! side-chain vectors.
5371 !
5372 !      implicit real*8 (a-h,o-z)
5373 !      include 'DIMENSIONS'
5374 !      include 'COMMON.GEO'
5375 !      include 'COMMON.VAR'
5376 !      include 'COMMON.LOCAL'
5377 !      include 'COMMON.CHAIN'
5378 !      include 'COMMON.DERIV'
5379 !      include 'COMMON.INTERACT'
5380 !      include 'COMMON.FFIELD'
5381 !      include 'COMMON.IOUNITS'
5382 !      include 'COMMON.CONTROL'
5383       real(kind=8),dimension(3) :: ggg
5384 !el local variables
5385       integer :: i,iint,j,k,iteli,itypj,subchap,icont
5386       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
5387                    e1,e2,evdwij,rij
5388       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
5389                     dist_temp, dist_init
5390       integer xshift,yshift,zshift
5391
5392       evdw2=0.0D0
5393       evdw2_14=0.0d0
5394 !d    print '(a)','Enter ESCP'
5395 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5396 !      do i=iatscp_s,iatscp_e
5397        do icont=g_listscp_start,g_listscp_end
5398         i=newcontlistscpi(icont)
5399         j=newcontlistscpj(icont)
5400         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5401         iteli=itel(i)
5402         xi=0.5D0*(c(1,i)+c(1,i+1))
5403         yi=0.5D0*(c(2,i)+c(2,i+1))
5404         zi=0.5D0*(c(3,i)+c(3,i+1))
5405         call to_box(xi,yi,zi)
5406
5407 !        do iint=1,nscp_gr(i)
5408
5409 !        do j=iscpstart(i,iint),iscpend(i,iint)
5410           itypj=iabs(itype(j,1))
5411           if (itypj.eq.ntyp1) cycle
5412 ! Uncomment following three lines for SC-p interactions
5413 !         xj=c(1,nres+j)-xi
5414 !         yj=c(2,nres+j)-yi
5415 !         zj=c(3,nres+j)-zi
5416 ! Uncomment following three lines for Ca-p interactions
5417 !          xj=c(1,j)-xi
5418 !          yj=c(2,j)-yi
5419 !          zj=c(3,j)-zi
5420           xj=c(1,j)
5421           yj=c(2,j)
5422           zj=c(3,j)
5423
5424           call to_box(xj,yj,zj)
5425           xj=boxshift(xj-xi,boxxsize)
5426           yj=boxshift(yj-yi,boxysize)
5427           zj=boxshift(zj-zi,boxzsize)
5428
5429           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5430           rij=dsqrt(1.0d0/rrij)
5431             sss_ele_cut=sscale_ele(rij)
5432             sss_ele_grad=sscagrad_ele(rij)
5433 !            print *,sss_ele_cut,sss_ele_grad,&
5434 !            (rij),r_cut_ele,rlamb_ele
5435             if (sss_ele_cut.le.0.0) cycle
5436           fac=rrij**expon2
5437           e1=fac*fac*aad(itypj,iteli)
5438           e2=fac*bad(itypj,iteli)
5439           if (iabs(j-i) .le. 2) then
5440             e1=scal14*e1
5441             e2=scal14*e2
5442             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5443           endif
5444           evdwij=e1+e2
5445           evdw2=evdw2+evdwij*sss_ele_cut
5446 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5447 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5448           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5449              'evdw2',i,j,evdwij
5450 !
5451 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5452 !
5453           fac=-(evdwij+e1)*rrij*sss_ele_cut
5454           fac=fac+evdwij*sss_ele_grad/rij/expon
5455           ggg(1)=xj*fac
5456           ggg(2)=yj*fac
5457           ggg(3)=zj*fac
5458 !grad          if (j.lt.i) then
5459 !d          write (iout,*) 'j<i'
5460 ! Uncomment following three lines for SC-p interactions
5461 !           do k=1,3
5462 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5463 !           enddo
5464 !grad          else
5465 !d          write (iout,*) 'j>i'
5466 !grad            do k=1,3
5467 !grad              ggg(k)=-ggg(k)
5468 ! Uncomment following line for SC-p interactions
5469 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5470 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5471 !grad            enddo
5472 !grad          endif
5473 !grad          do k=1,3
5474 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5475 !grad          enddo
5476 !grad          kstart=min0(i+1,j)
5477 !grad          kend=max0(i-1,j-1)
5478 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5479 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5480 !grad          do k=kstart,kend
5481 !grad            do l=1,3
5482 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5483 !grad            enddo
5484 !grad          enddo
5485           do k=1,3
5486             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5487             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5488           enddo
5489 !        enddo
5490
5491 !        enddo ! iint
5492       enddo ! i
5493       do i=1,nct
5494         do j=1,3
5495           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5496           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5497           gradx_scp(j,i)=expon*gradx_scp(j,i)
5498         enddo
5499       enddo
5500 !******************************************************************************
5501 !
5502 !                              N O T E !!!
5503 !
5504 ! To save time the factor EXPON has been extracted from ALL components
5505 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5506 ! use!
5507 !
5508 !******************************************************************************
5509       return
5510       end subroutine escp
5511 !-----------------------------------------------------------------------------
5512       subroutine edis(ehpb)
5513 !
5514 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5515 !
5516 !      implicit real*8 (a-h,o-z)
5517 !      include 'DIMENSIONS'
5518 !      include 'COMMON.SBRIDGE'
5519 !      include 'COMMON.CHAIN'
5520 !      include 'COMMON.DERIV'
5521 !      include 'COMMON.VAR'
5522 !      include 'COMMON.INTERACT'
5523 !      include 'COMMON.IOUNITS'
5524       real(kind=8),dimension(3) :: ggg
5525 !el local variables
5526       integer :: i,j,ii,jj,iii,jjj,k
5527       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5528
5529       ehpb=0.0D0
5530 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5531 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5532       if (link_end.eq.0) return
5533       do i=link_start,link_end
5534 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5535 ! CA-CA distance used in regularization of structure.
5536         ii=ihpb(i)
5537         jj=jhpb(i)
5538 ! iii and jjj point to the residues for which the distance is assigned.
5539         if (ii.gt.nres) then
5540           iii=ii-nres
5541           jjj=jj-nres
5542         else
5543           iii=ii
5544           jjj=jj
5545         endif
5546 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5547 !     &    dhpb(i),dhpb1(i),forcon(i)
5548 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5549 !    distance and angle dependent SS bond potential.
5550 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5551 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5552         if (.not.dyn_ss .and. i.le.nss) then
5553 ! 15/02/13 CC dynamic SSbond - additional check
5554          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5555         iabs(itype(jjj,1)).eq.1) then
5556           call ssbond_ene(iii,jjj,eij)
5557           ehpb=ehpb+2*eij
5558 !d          write (iout,*) "eij",eij
5559          endif
5560         else if (ii.gt.nres .and. jj.gt.nres) then
5561 !c Restraints from contact prediction
5562           dd=dist(ii,jj)
5563           if (constr_dist.eq.11) then
5564             ehpb=ehpb+fordepth(i)**4.0d0 &
5565                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5566             fac=fordepth(i)**4.0d0 &
5567                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5568           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5569             ehpb,fordepth(i),dd
5570            else
5571           if (dhpb1(i).gt.0.0d0) then
5572             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5573             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5574 !c            write (iout,*) "beta nmr",
5575 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5576           else
5577             dd=dist(ii,jj)
5578             rdis=dd-dhpb(i)
5579 !C Get the force constant corresponding to this distance.
5580             waga=forcon(i)
5581 !C Calculate the contribution to energy.
5582             ehpb=ehpb+waga*rdis*rdis
5583 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5584 !C
5585 !C Evaluate gradient.
5586 !C
5587             fac=waga*rdis/dd
5588           endif
5589           endif
5590           do j=1,3
5591             ggg(j)=fac*(c(j,jj)-c(j,ii))
5592           enddo
5593           do j=1,3
5594             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5595             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5596           enddo
5597           do k=1,3
5598             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5599             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5600           enddo
5601         else
5602           dd=dist(ii,jj)
5603           if (constr_dist.eq.11) then
5604             ehpb=ehpb+fordepth(i)**4.0d0 &
5605                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5606             fac=fordepth(i)**4.0d0 &
5607                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5608           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5609          ehpb,fordepth(i),dd
5610            else
5611           if (dhpb1(i).gt.0.0d0) then
5612             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5613             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5614 !c            write (iout,*) "alph nmr",
5615 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5616           else
5617             rdis=dd-dhpb(i)
5618 !C Get the force constant corresponding to this distance.
5619             waga=forcon(i)
5620 !C Calculate the contribution to energy.
5621             ehpb=ehpb+waga*rdis*rdis
5622 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5623 !C
5624 !C Evaluate gradient.
5625 !C
5626             fac=waga*rdis/dd
5627           endif
5628           endif
5629
5630             do j=1,3
5631               ggg(j)=fac*(c(j,jj)-c(j,ii))
5632             enddo
5633 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5634 !C If this is a SC-SC distance, we need to calculate the contributions to the
5635 !C Cartesian gradient in the SC vectors (ghpbx).
5636           if (iii.lt.ii) then
5637           do j=1,3
5638             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5639             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5640           enddo
5641           endif
5642 !cgrad        do j=iii,jjj-1
5643 !cgrad          do k=1,3
5644 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5645 !cgrad          enddo
5646 !cgrad        enddo
5647           do k=1,3
5648             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5649             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5650           enddo
5651         endif
5652       enddo
5653       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5654
5655       return
5656       end subroutine edis
5657 !-----------------------------------------------------------------------------
5658       subroutine ssbond_ene(i,j,eij)
5659 !
5660 ! Calculate the distance and angle dependent SS-bond potential energy
5661 ! using a free-energy function derived based on RHF/6-31G** ab initio
5662 ! calculations of diethyl disulfide.
5663 !
5664 ! A. Liwo and U. Kozlowska, 11/24/03
5665 !
5666 !      implicit real*8 (a-h,o-z)
5667 !      include 'DIMENSIONS'
5668 !      include 'COMMON.SBRIDGE'
5669 !      include 'COMMON.CHAIN'
5670 !      include 'COMMON.DERIV'
5671 !      include 'COMMON.LOCAL'
5672 !      include 'COMMON.INTERACT'
5673 !      include 'COMMON.VAR'
5674 !      include 'COMMON.IOUNITS'
5675       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5676 !el local variables
5677       integer :: i,j,itypi,itypj,k
5678       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5679                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5680                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5681                    cosphi,ggk
5682
5683       itypi=iabs(itype(i,1))
5684       xi=c(1,nres+i)
5685       yi=c(2,nres+i)
5686       zi=c(3,nres+i)
5687           call to_box(xi,yi,zi)
5688
5689       dxi=dc_norm(1,nres+i)
5690       dyi=dc_norm(2,nres+i)
5691       dzi=dc_norm(3,nres+i)
5692 !      dsci_inv=dsc_inv(itypi)
5693       dsci_inv=vbld_inv(nres+i)
5694       itypj=iabs(itype(j,1))
5695 !      dscj_inv=dsc_inv(itypj)
5696       dscj_inv=vbld_inv(nres+j)
5697 !      xj=c(1,nres+j)-xi
5698 !      yj=c(2,nres+j)-yi
5699 !      zj=c(3,nres+j)-zi
5700           call to_box(xj,yj,zj)
5701       xj=boxshift(xj-xi,boxxsize)
5702       yj=boxshift(yj-yi,boxysize)
5703       zj=boxshift(zj-zi,boxzsize)
5704       dxj=dc_norm(1,nres+j)
5705       dyj=dc_norm(2,nres+j)
5706       dzj=dc_norm(3,nres+j)
5707       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5708       rij=dsqrt(rrij)
5709       erij(1)=xj*rij
5710       erij(2)=yj*rij
5711       erij(3)=zj*rij
5712       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5713       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5714       om12=dxi*dxj+dyi*dyj+dzi*dzj
5715       do k=1,3
5716         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5717         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5718       enddo
5719       rij=1.0d0/rij
5720       deltad=rij-d0cm
5721       deltat1=1.0d0-om1
5722       deltat2=1.0d0+om2
5723       deltat12=om2-om1+2.0d0
5724       cosphi=om12-om1*om2
5725       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5726         +akct*deltad*deltat12 &
5727         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5728 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth, &
5729 !       " akct",akct," deltad",deltad," deltat",deltat1,deltat2, &
5730 !       " deltat12",deltat12," eij",eij
5731       ed=2*akcm*deltad+akct*deltat12
5732       pom1=akct*deltad
5733       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5734       eom1=-2*akth*deltat1-pom1-om2*pom2
5735       eom2= 2*akth*deltat2+pom1-om1*pom2
5736       eom12=pom2
5737       do k=1,3
5738         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5739         ghpbx(k,i)=ghpbx(k,i)-ggk &
5740                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5741                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5742         ghpbx(k,j)=ghpbx(k,j)+ggk &
5743                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5744                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5745         ghpbc(k,i)=ghpbc(k,i)-ggk
5746         ghpbc(k,j)=ghpbc(k,j)+ggk
5747       enddo
5748 !
5749 ! Calculate the components of the gradient in DC and X
5750 !
5751 !grad      do k=i,j-1
5752 !grad        do l=1,3
5753 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5754 !grad        enddo
5755 !grad      enddo
5756       return
5757       end subroutine ssbond_ene
5758 !-----------------------------------------------------------------------------
5759       subroutine ebond(estr)
5760 !
5761 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5762 !
5763 !      implicit real*8 (a-h,o-z)
5764 !      include 'DIMENSIONS'
5765 !      include 'COMMON.LOCAL'
5766 !      include 'COMMON.GEO'
5767 !      include 'COMMON.INTERACT'
5768 !      include 'COMMON.DERIV'
5769 !      include 'COMMON.VAR'
5770 !      include 'COMMON.CHAIN'
5771 !      include 'COMMON.IOUNITS'
5772 !      include 'COMMON.NAMES'
5773 !      include 'COMMON.FFIELD'
5774 !      include 'COMMON.CONTROL'
5775 !      include 'COMMON.SETUP'
5776       real(kind=8),dimension(3) :: u,ud
5777 !el local variables
5778       integer :: i,j,iti,nbi,k
5779       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5780                    uprod1,uprod2
5781
5782       estr=0.0d0
5783       estr1=0.0d0
5784 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5785 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5786
5787       do i=ibondp_start,ibondp_end
5788         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5789         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5790 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5791 !C          do j=1,3
5792 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5793 !C            *dc(j,i-1)/vbld(i)
5794 !C          enddo
5795 !C          if (energy_dec) write(iout,*) &
5796 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5797         diff = vbld(i)-vbldpDUM
5798         else
5799         diff = vbld(i)-vbldp0
5800         endif
5801         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5802            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5803         estr=estr+diff*diff
5804         do j=1,3
5805           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5806         enddo
5807 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5808 !        endif
5809       enddo
5810       estr=0.5d0*AKP*estr+estr1
5811 !      print *,"estr_bb",estr,AKP
5812 !
5813 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5814 !
5815       do i=ibond_start,ibond_end
5816         iti=iabs(itype(i,1))
5817         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5818         if (iti.ne.10 .and. iti.ne.ntyp1) then
5819           nbi=nbondterm(iti)
5820           if (nbi.eq.1) then
5821             diff=vbld(i+nres)-vbldsc0(1,iti)
5822             if (energy_dec) write (iout,*) &
5823             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5824             AKSC(1,iti),AKSC(1,iti)*diff*diff
5825             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5826 !            print *,"estr_sc",estr
5827             do j=1,3
5828               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5829             enddo
5830           else
5831             do j=1,nbi
5832               diff=vbld(i+nres)-vbldsc0(j,iti)
5833               ud(j)=aksc(j,iti)*diff
5834               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5835             enddo
5836             uprod=u(1)
5837             do j=2,nbi
5838               uprod=uprod*u(j)
5839             enddo
5840             usum=0.0d0
5841             usumsqder=0.0d0
5842             do j=1,nbi
5843               uprod1=1.0d0
5844               uprod2=1.0d0
5845               do k=1,nbi
5846                 if (k.ne.j) then
5847                   uprod1=uprod1*u(k)
5848                   uprod2=uprod2*u(k)*u(k)
5849                 endif
5850               enddo
5851               usum=usum+uprod1
5852               usumsqder=usumsqder+ud(j)*uprod2
5853             enddo
5854             estr=estr+uprod/usum
5855 !            print *,"estr_sc",estr,i
5856
5857              if (energy_dec) write (iout,*) &
5858             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5859             AKSC(1,iti),uprod/usum
5860             do j=1,3
5861              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5862             enddo
5863           endif
5864         endif
5865       enddo
5866       return
5867       end subroutine ebond
5868 #ifdef CRYST_THETA
5869 !-----------------------------------------------------------------------------
5870       subroutine ebend(etheta)
5871 !
5872 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5873 ! angles gamma and its derivatives in consecutive thetas and gammas.
5874 !
5875       use comm_calcthet
5876 !      implicit real*8 (a-h,o-z)
5877 !      include 'DIMENSIONS'
5878 !      include 'COMMON.LOCAL'
5879 !      include 'COMMON.GEO'
5880 !      include 'COMMON.INTERACT'
5881 !      include 'COMMON.DERIV'
5882 !      include 'COMMON.VAR'
5883 !      include 'COMMON.CHAIN'
5884 !      include 'COMMON.IOUNITS'
5885 !      include 'COMMON.NAMES'
5886 !      include 'COMMON.FFIELD'
5887 !      include 'COMMON.CONTROL'
5888 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5889 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5890 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5891 !el      integer :: it
5892 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5893 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5894 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5895 !el local variables
5896       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5897        ichir21,ichir22
5898       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5899        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5900        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5901       real(kind=8),dimension(2) :: y,z
5902
5903       delta=0.02d0*pi
5904 !      time11=dexp(-2*time)
5905 !      time12=1.0d0
5906       etheta=0.0D0
5907 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5908       do i=ithet_start,ithet_end
5909         if (itype(i-1,1).eq.ntyp1) cycle
5910 ! Zero the energy function and its derivative at 0 or pi.
5911         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5912         it=itype(i-1,1)
5913         ichir1=isign(1,itype(i-2,1))
5914         ichir2=isign(1,itype(i,1))
5915          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
5916          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
5917          if (itype(i-1,1).eq.10) then
5918           itype1=isign(10,itype(i-2,1))
5919           ichir11=isign(1,itype(i-2,1))
5920           ichir12=isign(1,itype(i-2,1))
5921           itype2=isign(10,itype(i,1))
5922           ichir21=isign(1,itype(i,1))
5923           ichir22=isign(1,itype(i,1))
5924          endif
5925
5926         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
5927 #ifdef OSF
5928           phii=phi(i)
5929           if (phii.ne.phii) phii=150.0
5930 #else
5931           phii=phi(i)
5932 #endif
5933           y(1)=dcos(phii)
5934           y(2)=dsin(phii)
5935         else
5936           y(1)=0.0D0
5937           y(2)=0.0D0
5938         endif
5939         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
5940 #ifdef OSF
5941           phii1=phi(i+1)
5942           if (phii1.ne.phii1) phii1=150.0
5943           phii1=pinorm(phii1)
5944           z(1)=cos(phii1)
5945 #else
5946           phii1=phi(i+1)
5947           z(1)=dcos(phii1)
5948 #endif
5949           z(2)=dsin(phii1)
5950         else
5951           z(1)=0.0D0
5952           z(2)=0.0D0
5953         endif
5954 ! Calculate the "mean" value of theta from the part of the distribution
5955 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5956 ! In following comments this theta will be referred to as t_c.
5957         thet_pred_mean=0.0d0
5958         do k=1,2
5959             athetk=athet(k,it,ichir1,ichir2)
5960             bthetk=bthet(k,it,ichir1,ichir2)
5961           if (it.eq.10) then
5962              athetk=athet(k,itype1,ichir11,ichir12)
5963              bthetk=bthet(k,itype2,ichir21,ichir22)
5964           endif
5965          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5966         enddo
5967         dthett=thet_pred_mean*ssd
5968         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5969 ! Derivatives of the "mean" values in gamma1 and gamma2.
5970         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5971                +athet(2,it,ichir1,ichir2)*y(1))*ss
5972         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5973                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5974          if (it.eq.10) then
5975         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5976              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5977         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5978                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5979          endif
5980         if (theta(i).gt.pi-delta) then
5981           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5982                E_tc0)
5983           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5984           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5985           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5986               E_theta)
5987           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
5988               E_tc)
5989         else if (theta(i).lt.delta) then
5990           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5991           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5992           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
5993               E_theta)
5994           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5995           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
5996               E_tc)
5997         else
5998           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
5999               E_theta,E_tc)
6000         endif
6001         etheta=etheta+ethetai
6002         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6003             'ebend',i,ethetai
6004         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6005         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6006         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
6007       enddo
6008 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6009
6010 ! Ufff.... We've done all this!!!
6011       return
6012       end subroutine ebend
6013 !-----------------------------------------------------------------------------
6014       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
6015
6016       use comm_calcthet
6017 !      implicit real*8 (a-h,o-z)
6018 !      include 'DIMENSIONS'
6019 !      include 'COMMON.LOCAL'
6020 !      include 'COMMON.IOUNITS'
6021 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6022 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6023 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6024       integer :: i,j,k
6025       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
6026 !el      integer :: it
6027 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6028 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6029 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6030 !el local variables
6031       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
6032        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6033
6034 ! Calculate the contributions to both Gaussian lobes.
6035 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6036 ! The "polynomial part" of the "standard deviation" of this part of
6037 ! the distribution.
6038         sig=polthet(3,it)
6039         do j=2,0,-1
6040           sig=sig*thet_pred_mean+polthet(j,it)
6041         enddo
6042 ! Derivative of the "interior part" of the "standard deviation of the"
6043 ! gamma-dependent Gaussian lobe in t_c.
6044         sigtc=3*polthet(3,it)
6045         do j=2,1,-1
6046           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6047         enddo
6048         sigtc=sig*sigtc
6049 ! Set the parameters of both Gaussian lobes of the distribution.
6050 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6051         fac=sig*sig+sigc0(it)
6052         sigcsq=fac+fac
6053         sigc=1.0D0/sigcsq
6054 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6055         sigsqtc=-4.0D0*sigcsq*sigtc
6056 !       print *,i,sig,sigtc,sigsqtc
6057 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
6058         sigtc=-sigtc/(fac*fac)
6059 ! Following variable is sigma(t_c)**(-2)
6060         sigcsq=sigcsq*sigcsq
6061         sig0i=sig0(it)
6062         sig0inv=1.0D0/sig0i**2
6063         delthec=thetai-thet_pred_mean
6064         delthe0=thetai-theta0i
6065         term1=-0.5D0*sigcsq*delthec*delthec
6066         term2=-0.5D0*sig0inv*delthe0*delthe0
6067 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6068 ! NaNs in taking the logarithm. We extract the largest exponent which is added
6069 ! to the energy (this being the log of the distribution) at the end of energy
6070 ! term evaluation for this virtual-bond angle.
6071         if (term1.gt.term2) then
6072           termm=term1
6073           term2=dexp(term2-termm)
6074           term1=1.0d0
6075         else
6076           termm=term2
6077           term1=dexp(term1-termm)
6078           term2=1.0d0
6079         endif
6080 ! The ratio between the gamma-independent and gamma-dependent lobes of
6081 ! the distribution is a Gaussian function of thet_pred_mean too.
6082         diffak=gthet(2,it)-thet_pred_mean
6083         ratak=diffak/gthet(3,it)**2
6084         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6085 ! Let's differentiate it in thet_pred_mean NOW.
6086         aktc=ak*ratak
6087 ! Now put together the distribution terms to make complete distribution.
6088         termexp=term1+ak*term2
6089         termpre=sigc+ak*sig0i
6090 ! Contribution of the bending energy from this theta is just the -log of
6091 ! the sum of the contributions from the two lobes and the pre-exponential
6092 ! factor. Simple enough, isn't it?
6093         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6094 ! NOW the derivatives!!!
6095 ! 6/6/97 Take into account the deformation.
6096         E_theta=(delthec*sigcsq*term1 &
6097              +ak*delthe0*sig0inv*term2)/termexp
6098         E_tc=((sigtc+aktc*sig0i)/termpre &
6099             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
6100              aktc*term2)/termexp)
6101       return
6102       end subroutine theteng
6103 #else
6104 !-----------------------------------------------------------------------------
6105       subroutine ebend(etheta)
6106 !
6107 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6108 ! angles gamma and its derivatives in consecutive thetas and gammas.
6109 ! ab initio-derived potentials from
6110 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6111 !
6112 !      implicit real*8 (a-h,o-z)
6113 !      include 'DIMENSIONS'
6114 !      include 'COMMON.LOCAL'
6115 !      include 'COMMON.GEO'
6116 !      include 'COMMON.INTERACT'
6117 !      include 'COMMON.DERIV'
6118 !      include 'COMMON.VAR'
6119 !      include 'COMMON.CHAIN'
6120 !      include 'COMMON.IOUNITS'
6121 !      include 'COMMON.NAMES'
6122 !      include 'COMMON.FFIELD'
6123 !      include 'COMMON.CONTROL'
6124       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
6125       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
6126       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
6127       logical :: lprn=.false., lprn1=.false.
6128 !el local variables
6129       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
6130       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
6131       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
6132 ! local variables for constrains
6133       real(kind=8) :: difi,thetiii
6134        integer itheta
6135 !      write(iout,*) "in ebend",ithet_start,ithet_end
6136       call flush(iout)
6137       etheta=0.0D0
6138       do i=ithet_start,ithet_end
6139         if (itype(i-1,1).eq.ntyp1) cycle
6140         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
6141         if (iabs(itype(i+1,1)).eq.20) iblock=2
6142         if (iabs(itype(i+1,1)).ne.20) iblock=1
6143         dethetai=0.0d0
6144         dephii=0.0d0
6145         dephii1=0.0d0
6146         theti2=0.5d0*theta(i)
6147         ityp2=ithetyp((itype(i-1,1)))
6148         do k=1,nntheterm
6149           coskt(k)=dcos(k*theti2)
6150           sinkt(k)=dsin(k*theti2)
6151         enddo
6152         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
6153 #ifdef OSF
6154           phii=phi(i)
6155           if (phii.ne.phii) phii=150.0
6156 #else
6157           phii=phi(i)
6158 #endif
6159           ityp1=ithetyp((itype(i-2,1)))
6160 ! propagation of chirality for glycine type
6161           do k=1,nsingle
6162             cosph1(k)=dcos(k*phii)
6163             sinph1(k)=dsin(k*phii)
6164           enddo
6165         else
6166           phii=0.0d0
6167           ityp1=ithetyp(itype(i-2,1))
6168           do k=1,nsingle
6169             cosph1(k)=0.0d0
6170             sinph1(k)=0.0d0
6171           enddo
6172         endif
6173         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
6174 #ifdef OSF
6175           phii1=phi(i+1)
6176           if (phii1.ne.phii1) phii1=150.0
6177           phii1=pinorm(phii1)
6178 #else
6179           phii1=phi(i+1)
6180 #endif
6181           ityp3=ithetyp((itype(i,1)))
6182           do k=1,nsingle
6183             cosph2(k)=dcos(k*phii1)
6184             sinph2(k)=dsin(k*phii1)
6185           enddo
6186         else
6187           phii1=0.0d0
6188           ityp3=ithetyp(itype(i,1))
6189           do k=1,nsingle
6190             cosph2(k)=0.0d0
6191             sinph2(k)=0.0d0
6192           enddo
6193         endif
6194         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6195         do k=1,ndouble
6196           do l=1,k-1
6197             ccl=cosph1(l)*cosph2(k-l)
6198             ssl=sinph1(l)*sinph2(k-l)
6199             scl=sinph1(l)*cosph2(k-l)
6200             csl=cosph1(l)*sinph2(k-l)
6201             cosph1ph2(l,k)=ccl-ssl
6202             cosph1ph2(k,l)=ccl+ssl
6203             sinph1ph2(l,k)=scl+csl
6204             sinph1ph2(k,l)=scl-csl
6205           enddo
6206         enddo
6207         if (lprn) then
6208         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
6209           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6210         write (iout,*) "coskt and sinkt"
6211         do k=1,nntheterm
6212           write (iout,*) k,coskt(k),sinkt(k)
6213         enddo
6214         endif
6215         do k=1,ntheterm
6216           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6217           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
6218             *coskt(k)
6219           if (lprn) &
6220           write (iout,*) "k",k,&
6221            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
6222            " ethetai",ethetai
6223         enddo
6224         if (lprn) then
6225         write (iout,*) "cosph and sinph"
6226         do k=1,nsingle
6227           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6228         enddo
6229         write (iout,*) "cosph1ph2 and sinph2ph2"
6230         do k=2,ndouble
6231           do l=1,k-1
6232             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
6233                sinph1ph2(l,k),sinph1ph2(k,l)
6234           enddo
6235         enddo
6236         write(iout,*) "ethetai",ethetai
6237         endif
6238         do m=1,ntheterm2
6239           do k=1,nsingle
6240             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
6241                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
6242                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
6243                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6244             ethetai=ethetai+sinkt(m)*aux
6245             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6246             dephii=dephii+k*sinkt(m)* &
6247                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
6248                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6249             dephii1=dephii1+k*sinkt(m)* &
6250                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
6251                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6252             if (lprn) &
6253             write (iout,*) "m",m," k",k," bbthet", &
6254                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
6255                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
6256                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
6257                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6258           enddo
6259         enddo
6260         if (lprn) &
6261         write(iout,*) "ethetai",ethetai
6262         do m=1,ntheterm3
6263           do k=2,ndouble
6264             do l=1,k-1
6265               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6266                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
6267                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6268                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6269               ethetai=ethetai+sinkt(m)*aux
6270               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6271               dephii=dephii+l*sinkt(m)* &
6272                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
6273                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6274                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6275                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6276               dephii1=dephii1+(k-l)*sinkt(m)* &
6277                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6278                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6279                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
6280                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6281               if (lprn) then
6282               write (iout,*) "m",m," k",k," l",l," ffthet",&
6283                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6284                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
6285                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6286                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
6287                   " ethetai",ethetai
6288               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
6289                   cosph1ph2(k,l)*sinkt(m),&
6290                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6291               endif
6292             enddo
6293           enddo
6294         enddo
6295 10      continue
6296 !        lprn1=.true.
6297         if (lprn1) &
6298           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
6299          i,theta(i)*rad2deg,phii*rad2deg,&
6300          phii1*rad2deg,ethetai
6301 !        lprn1=.false.
6302         etheta=etheta+ethetai
6303         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6304                                     'ebend',i,ethetai
6305         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6306         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6307         gloc(nphi+i-2,icg)=wang*dethetai
6308       enddo
6309 !-----------thete constrains
6310 !      if (tor_mode.ne.2) then
6311
6312       return
6313       end subroutine ebend
6314 #endif
6315 #ifdef CRYST_SC
6316 !-----------------------------------------------------------------------------
6317       subroutine esc(escloc)
6318 ! Calculate the local energy of a side chain and its derivatives in the
6319 ! corresponding virtual-bond valence angles THETA and the spherical angles
6320 ! ALPHA and OMEGA.
6321 !
6322       use comm_sccalc
6323 !      implicit real*8 (a-h,o-z)
6324 !      include 'DIMENSIONS'
6325 !      include 'COMMON.GEO'
6326 !      include 'COMMON.LOCAL'
6327 !      include 'COMMON.VAR'
6328 !      include 'COMMON.INTERACT'
6329 !      include 'COMMON.DERIV'
6330 !      include 'COMMON.CHAIN'
6331 !      include 'COMMON.IOUNITS'
6332 !      include 'COMMON.NAMES'
6333 !      include 'COMMON.FFIELD'
6334 !      include 'COMMON.CONTROL'
6335       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
6336          ddersc0,ddummy,xtemp,temp
6337 !el      real(kind=8) :: time11,time12,time112,theti
6338       real(kind=8) :: escloc,delta
6339 !el      integer :: it,nlobit
6340 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6341 !el local variables
6342       integer :: i,k
6343       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
6344        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6345       delta=0.02d0*pi
6346       escloc=0.0D0
6347 !     write (iout,'(a)') 'ESC'
6348       do i=loc_start,loc_end
6349         it=itype(i,1)
6350         if (it.eq.ntyp1) cycle
6351         if (it.eq.10) goto 1
6352         nlobit=nlob(iabs(it))
6353 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
6354 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6355         theti=theta(i+1)-pipol
6356         x(1)=dtan(theti)
6357         x(2)=alph(i)
6358         x(3)=omeg(i)
6359
6360         if (x(2).gt.pi-delta) then
6361           xtemp(1)=x(1)
6362           xtemp(2)=pi-delta
6363           xtemp(3)=x(3)
6364           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6365           xtemp(2)=pi
6366           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6367           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
6368               escloci,dersc(2))
6369           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6370               ddersc0(1),dersc(1))
6371           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
6372               ddersc0(3),dersc(3))
6373           xtemp(2)=pi-delta
6374           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6375           xtemp(2)=pi
6376           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6377           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
6378                   dersc0(2),esclocbi,dersc02)
6379           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6380                   dersc12,dersc01)
6381           call splinthet(x(2),0.5d0*delta,ss,ssd)
6382           dersc0(1)=dersc01
6383           dersc0(2)=dersc02
6384           dersc0(3)=0.0d0
6385           do k=1,3
6386             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6387           enddo
6388           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6389 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6390 !    &             esclocbi,ss,ssd
6391           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6392 !         escloci=esclocbi
6393 !         write (iout,*) escloci
6394         else if (x(2).lt.delta) then
6395           xtemp(1)=x(1)
6396           xtemp(2)=delta
6397           xtemp(3)=x(3)
6398           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6399           xtemp(2)=0.0d0
6400           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6401           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
6402               escloci,dersc(2))
6403           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6404               ddersc0(1),dersc(1))
6405           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6406               ddersc0(3),dersc(3))
6407           xtemp(2)=delta
6408           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6409           xtemp(2)=0.0d0
6410           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6411           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6412                   dersc0(2),esclocbi,dersc02)
6413           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6414                   dersc12,dersc01)
6415           dersc0(1)=dersc01
6416           dersc0(2)=dersc02
6417           dersc0(3)=0.0d0
6418           call splinthet(x(2),0.5d0*delta,ss,ssd)
6419           do k=1,3
6420             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6421           enddo
6422           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6423 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6424 !    &             esclocbi,ss,ssd
6425           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6426 !         write (iout,*) escloci
6427         else
6428           call enesc(x,escloci,dersc,ddummy,.false.)
6429         endif
6430
6431         escloc=escloc+escloci
6432         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6433            'escloc',i,escloci
6434 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6435
6436         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6437          wscloc*dersc(1)
6438         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6439         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6440     1   continue
6441       enddo
6442       return
6443       end subroutine esc
6444 !-----------------------------------------------------------------------------
6445       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6446
6447       use comm_sccalc
6448 !      implicit real*8 (a-h,o-z)
6449 !      include 'DIMENSIONS'
6450 !      include 'COMMON.GEO'
6451 !      include 'COMMON.LOCAL'
6452 !      include 'COMMON.IOUNITS'
6453 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6454       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6455       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6456       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6457       real(kind=8) :: escloci
6458       logical :: mixed
6459 !el local variables
6460       integer :: j,iii,l,k !el,it,nlobit
6461       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6462 !el       time11,time12,time112
6463 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6464         escloc_i=0.0D0
6465         do j=1,3
6466           dersc(j)=0.0D0
6467           if (mixed) ddersc(j)=0.0d0
6468         enddo
6469         x3=x(3)
6470
6471 ! Because of periodicity of the dependence of the SC energy in omega we have
6472 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6473 ! To avoid underflows, first compute & store the exponents.
6474
6475         do iii=-1,1
6476
6477           x(3)=x3+iii*dwapi
6478
6479           do j=1,nlobit
6480             do k=1,3
6481               z(k)=x(k)-censc(k,j,it)
6482             enddo
6483             do k=1,3
6484               Axk=0.0D0
6485               do l=1,3
6486                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6487               enddo
6488               Ax(k,j,iii)=Axk
6489             enddo
6490             expfac=0.0D0
6491             do k=1,3
6492               expfac=expfac+Ax(k,j,iii)*z(k)
6493             enddo
6494             contr(j,iii)=expfac
6495           enddo ! j
6496
6497         enddo ! iii
6498
6499         x(3)=x3
6500 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6501 ! subsequent NaNs and INFs in energy calculation.
6502 ! Find the largest exponent
6503         emin=contr(1,-1)
6504         do iii=-1,1
6505           do j=1,nlobit
6506             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6507           enddo
6508         enddo
6509         emin=0.5D0*emin
6510 !d      print *,'it=',it,' emin=',emin
6511
6512 ! Compute the contribution to SC energy and derivatives
6513         do iii=-1,1
6514
6515           do j=1,nlobit
6516 #ifdef OSF
6517             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6518             if(adexp.ne.adexp) adexp=1.0
6519             expfac=dexp(adexp)
6520 #else
6521             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6522 #endif
6523 !d          print *,'j=',j,' expfac=',expfac
6524             escloc_i=escloc_i+expfac
6525             do k=1,3
6526               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6527             enddo
6528             if (mixed) then
6529               do k=1,3,2
6530                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6531                   +gaussc(k,2,j,it))*expfac
6532               enddo
6533             endif
6534           enddo
6535
6536         enddo ! iii
6537
6538         dersc(1)=dersc(1)/cos(theti)**2
6539         ddersc(1)=ddersc(1)/cos(theti)**2
6540         ddersc(3)=ddersc(3)
6541
6542         escloci=-(dlog(escloc_i)-emin)
6543         do j=1,3
6544           dersc(j)=dersc(j)/escloc_i
6545         enddo
6546         if (mixed) then
6547           do j=1,3,2
6548             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6549           enddo
6550         endif
6551       return
6552       end subroutine enesc
6553 !-----------------------------------------------------------------------------
6554       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6555
6556       use comm_sccalc
6557 !      implicit real*8 (a-h,o-z)
6558 !      include 'DIMENSIONS'
6559 !      include 'COMMON.GEO'
6560 !      include 'COMMON.LOCAL'
6561 !      include 'COMMON.IOUNITS'
6562 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6563       real(kind=8),dimension(3) :: x,z,dersc
6564       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6565       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6566       real(kind=8) :: escloci,dersc12,emin
6567       logical :: mixed
6568 !el local varables
6569       integer :: j,k,l !el,it,nlobit
6570       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6571
6572       escloc_i=0.0D0
6573
6574       do j=1,3
6575         dersc(j)=0.0D0
6576       enddo
6577
6578       do j=1,nlobit
6579         do k=1,2
6580           z(k)=x(k)-censc(k,j,it)
6581         enddo
6582         z(3)=dwapi
6583         do k=1,3
6584           Axk=0.0D0
6585           do l=1,3
6586             Axk=Axk+gaussc(l,k,j,it)*z(l)
6587           enddo
6588           Ax(k,j)=Axk
6589         enddo
6590         expfac=0.0D0
6591         do k=1,3
6592           expfac=expfac+Ax(k,j)*z(k)
6593         enddo
6594         contr(j)=expfac
6595       enddo ! j
6596
6597 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6598 ! subsequent NaNs and INFs in energy calculation.
6599 ! Find the largest exponent
6600       emin=contr(1)
6601       do j=1,nlobit
6602         if (emin.gt.contr(j)) emin=contr(j)
6603       enddo
6604       emin=0.5D0*emin
6605
6606 ! Compute the contribution to SC energy and derivatives
6607
6608       dersc12=0.0d0
6609       do j=1,nlobit
6610         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6611         escloc_i=escloc_i+expfac
6612         do k=1,2
6613           dersc(k)=dersc(k)+Ax(k,j)*expfac
6614         enddo
6615         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6616                   +gaussc(1,2,j,it))*expfac
6617         dersc(3)=0.0d0
6618       enddo
6619
6620       dersc(1)=dersc(1)/cos(theti)**2
6621       dersc12=dersc12/cos(theti)**2
6622       escloci=-(dlog(escloc_i)-emin)
6623       do j=1,2
6624         dersc(j)=dersc(j)/escloc_i
6625       enddo
6626       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6627       return
6628       end subroutine enesc_bound
6629 #else
6630 !-----------------------------------------------------------------------------
6631       subroutine esc(escloc)
6632 ! Calculate the local energy of a side chain and its derivatives in the
6633 ! corresponding virtual-bond valence angles THETA and the spherical angles
6634 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6635 ! added by Urszula Kozlowska. 07/11/2007
6636 !
6637       use comm_sccalc
6638 !      implicit real*8 (a-h,o-z)
6639 !      include 'DIMENSIONS'
6640 !      include 'COMMON.GEO'
6641 !      include 'COMMON.LOCAL'
6642 !      include 'COMMON.VAR'
6643 !      include 'COMMON.SCROT'
6644 !      include 'COMMON.INTERACT'
6645 !      include 'COMMON.DERIV'
6646 !      include 'COMMON.CHAIN'
6647 !      include 'COMMON.IOUNITS'
6648 !      include 'COMMON.NAMES'
6649 !      include 'COMMON.FFIELD'
6650 !      include 'COMMON.CONTROL'
6651 !      include 'COMMON.VECTORS'
6652       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6653       real(kind=8),dimension(65) :: x
6654       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6655          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6656       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6657       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6658          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6659 !el local variables
6660       integer :: i,j,k !el,it,nlobit
6661       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6662 !el      real(kind=8) :: time11,time12,time112,theti
6663 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6664       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6665                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6666                    sumene1x,sumene2x,sumene3x,sumene4x,&
6667                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6668                    cosfac2xx,sinfac2yy
6669 #ifdef DEBUG
6670       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6671                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6672                    de_dt_num
6673 #endif
6674 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6675
6676       delta=0.02d0*pi
6677       escloc=0.0D0
6678       do i=loc_start,loc_end
6679         if (itype(i,1).eq.ntyp1) cycle
6680         costtab(i+1) =dcos(theta(i+1))
6681         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6682         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6683         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6684         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6685         cosfac=dsqrt(cosfac2)
6686         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6687         sinfac=dsqrt(sinfac2)
6688         it=iabs(itype(i,1))
6689         if (it.eq.10) goto 1
6690 !
6691 !  Compute the axes of tghe local cartesian coordinates system; store in
6692 !   x_prime, y_prime and z_prime
6693 !
6694         do j=1,3
6695           x_prime(j) = 0.00
6696           y_prime(j) = 0.00
6697           z_prime(j) = 0.00
6698         enddo
6699 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6700 !     &   dc_norm(3,i+nres)
6701         do j = 1,3
6702           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6703           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6704         enddo
6705         do j = 1,3
6706           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6707         enddo
6708 !       write (2,*) "i",i
6709 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6710 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6711 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6712 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6713 !      & " xy",scalar(x_prime(1),y_prime(1)),
6714 !      & " xz",scalar(x_prime(1),z_prime(1)),
6715 !      & " yy",scalar(y_prime(1),y_prime(1)),
6716 !      & " yz",scalar(y_prime(1),z_prime(1)),
6717 !      & " zz",scalar(z_prime(1),z_prime(1))
6718 !
6719 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6720 ! to local coordinate system. Store in xx, yy, zz.
6721 !
6722         xx=0.0d0
6723         yy=0.0d0
6724         zz=0.0d0
6725         do j = 1,3
6726           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6727           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6728           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6729         enddo
6730
6731         xxtab(i)=xx
6732         yytab(i)=yy
6733         zztab(i)=zz
6734 !
6735 ! Compute the energy of the ith side cbain
6736 !
6737 !        write (2,*) "xx",xx," yy",yy," zz",zz
6738         it=iabs(itype(i,1))
6739         do j = 1,65
6740           x(j) = sc_parmin(j,it)
6741         enddo
6742 #ifdef CHECK_COORD
6743 !c diagnostics - remove later
6744         xx1 = dcos(alph(2))
6745         yy1 = dsin(alph(2))*dcos(omeg(2))
6746         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6747         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6748           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6749           xx1,yy1,zz1
6750 !,"  --- ", xx_w,yy_w,zz_w
6751 ! end diagnostics
6752 #endif
6753         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6754          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6755          + x(10)*yy*zz
6756         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6757          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6758          + x(20)*yy*zz
6759         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6760          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6761          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6762          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6763          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6764          +x(40)*xx*yy*zz
6765         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6766          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6767          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6768          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6769          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6770          +x(60)*xx*yy*zz
6771         dsc_i   = 0.743d0+x(61)
6772         dp2_i   = 1.9d0+x(62)
6773         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6774                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6775         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6776                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6777         s1=(1+x(63))/(0.1d0 + dscp1)
6778         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6779         s2=(1+x(65))/(0.1d0 + dscp2)
6780         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6781         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6782       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6783 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6784 !     &   sumene4,
6785 !     &   dscp1,dscp2,sumene
6786 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6787         escloc = escloc + sumene
6788        if (energy_dec) write (2,*) "i",i," itype",itype(i,1)," it",it, &
6789         " escloc",sumene,escloc,it,itype(i,1)
6790 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6791 !     & ,zz,xx,yy
6792 !#define DEBUG
6793 #ifdef DEBUG
6794 !
6795 ! This section to check the numerical derivatives of the energy of ith side
6796 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6797 ! #define DEBUG in the code to turn it on.
6798 !
6799         write (2,*) "sumene               =",sumene
6800         aincr=1.0d-7
6801         xxsave=xx
6802         xx=xx+aincr
6803         write (2,*) xx,yy,zz
6804         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6805         de_dxx_num=(sumenep-sumene)/aincr
6806         xx=xxsave
6807         write (2,*) "xx+ sumene from enesc=",sumenep
6808         yysave=yy
6809         yy=yy+aincr
6810         write (2,*) xx,yy,zz
6811         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6812         de_dyy_num=(sumenep-sumene)/aincr
6813         yy=yysave
6814         write (2,*) "yy+ sumene from enesc=",sumenep
6815         zzsave=zz
6816         zz=zz+aincr
6817         write (2,*) xx,yy,zz
6818         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6819         de_dzz_num=(sumenep-sumene)/aincr
6820         zz=zzsave
6821         write (2,*) "zz+ sumene from enesc=",sumenep
6822         costsave=cost2tab(i+1)
6823         sintsave=sint2tab(i+1)
6824         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6825         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6826         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6827         de_dt_num=(sumenep-sumene)/aincr
6828         write (2,*) " t+ sumene from enesc=",sumenep
6829         cost2tab(i+1)=costsave
6830         sint2tab(i+1)=sintsave
6831 ! End of diagnostics section.
6832 #endif
6833 !
6834 ! Compute the gradient of esc
6835 !
6836 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6837         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6838         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6839         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6840         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6841         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6842         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6843         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6844         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6845         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6846            *(pom_s1/dscp1+pom_s16*dscp1**4)
6847         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6848            *(pom_s2/dscp2+pom_s26*dscp2**4)
6849         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6850         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6851         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6852         +x(40)*yy*zz
6853         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6854         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6855         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6856         +x(60)*yy*zz
6857         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6858               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6859               +(pom1+pom2)*pom_dx
6860 #ifdef DEBUG
6861         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6862 #endif
6863 !
6864         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6865         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6866         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6867         +x(40)*xx*zz
6868         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6869         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6870         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6871         +x(59)*zz**2 +x(60)*xx*zz
6872         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6873               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6874               +(pom1-pom2)*pom_dy
6875 #ifdef DEBUG
6876         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6877 #endif
6878 !
6879         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6880         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6881         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6882         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6883         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6884         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6885         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6886         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6887 #ifdef DEBUG
6888         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
6889 #endif
6890 !
6891         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6892         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6893         +pom1*pom_dt1+pom2*pom_dt2
6894 #ifdef DEBUG
6895         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
6896 #endif
6897 !
6898 !
6899        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6900        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6901        cosfac2xx=cosfac2*xx
6902        sinfac2yy=sinfac2*yy
6903        do k = 1,3
6904          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6905             vbld_inv(i+1)
6906          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6907             vbld_inv(i)
6908          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6909          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6910 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6911 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6912 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6913 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6914          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6915          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6916          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6917          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6918          dZZ_Ci1(k)=0.0d0
6919          dZZ_Ci(k)=0.0d0
6920          do j=1,3
6921            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6922            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6923            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6924            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6925          enddo
6926
6927          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6928          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6929          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6930          (z_prime(k)-zz*dC_norm(k,i+nres))
6931 !
6932          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6933          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6934        enddo
6935
6936        do k=1,3
6937          dXX_Ctab(k,i)=dXX_Ci(k)
6938          dXX_C1tab(k,i)=dXX_Ci1(k)
6939          dYY_Ctab(k,i)=dYY_Ci(k)
6940          dYY_C1tab(k,i)=dYY_Ci1(k)
6941          dZZ_Ctab(k,i)=dZZ_Ci(k)
6942          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6943          dXX_XYZtab(k,i)=dXX_XYZ(k)
6944          dYY_XYZtab(k,i)=dYY_XYZ(k)
6945          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6946        enddo
6947
6948        do k = 1,3
6949 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6950 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6951 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6952 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6953 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6954 !     &    dt_dci(k)
6955 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6956 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6957          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6958           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6959          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6960           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6961          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6962           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6963        enddo
6964 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6965 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6966
6967 ! to check gradient call subroutine check_grad
6968
6969     1 continue
6970       enddo
6971       return
6972       end subroutine esc
6973 !-----------------------------------------------------------------------------
6974       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6975 !      implicit none
6976       real(kind=8),dimension(65) :: x
6977       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6978         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6979
6980       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6981         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6982         + x(10)*yy*zz
6983       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6984         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6985         + x(20)*yy*zz
6986       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6987         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6988         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6989         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6990         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6991         +x(40)*xx*yy*zz
6992       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6993         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6994         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6995         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6996         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6997         +x(60)*xx*yy*zz
6998       dsc_i   = 0.743d0+x(61)
6999       dp2_i   = 1.9d0+x(62)
7000       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7001                 *(xx*cost2+yy*sint2))
7002       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7003                 *(xx*cost2-yy*sint2))
7004       s1=(1+x(63))/(0.1d0 + dscp1)
7005       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7006       s2=(1+x(65))/(0.1d0 + dscp2)
7007       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7008       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
7009        + (sumene4*cost2 +sumene2)*(s2+s2_6)
7010       enesc=sumene
7011       return
7012       end function enesc
7013 #endif
7014 !-----------------------------------------------------------------------------
7015       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7016 !
7017 ! This procedure calculates two-body contact function g(rij) and its derivative:
7018 !
7019 !           eps0ij                                     !       x < -1
7020 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7021 !            0                                         !       x > 1
7022 !
7023 ! where x=(rij-r0ij)/delta
7024 !
7025 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7026 !
7027 !      implicit none
7028       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
7029       real(kind=8) :: x,x2,x4,delta
7030 !     delta=0.02D0*r0ij
7031 !      delta=0.2D0*r0ij
7032       x=(rij-r0ij)/delta
7033       if (x.lt.-1.0D0) then
7034         fcont=eps0ij
7035         fprimcont=0.0D0
7036       else if (x.le.1.0D0) then
7037         x2=x*x
7038         x4=x2*x2
7039         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7040         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7041       else
7042         fcont=0.0D0
7043         fprimcont=0.0D0
7044       endif
7045       return
7046       end subroutine gcont
7047 !-----------------------------------------------------------------------------
7048       subroutine splinthet(theti,delta,ss,ssder)
7049 !      implicit real*8 (a-h,o-z)
7050 !      include 'DIMENSIONS'
7051 !      include 'COMMON.VAR'
7052 !      include 'COMMON.GEO'
7053       real(kind=8) :: theti,delta,ss,ssder
7054       real(kind=8) :: thetup,thetlow
7055       thetup=pi-delta
7056       thetlow=delta
7057       if (theti.gt.pipol) then
7058         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7059       else
7060         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7061         ssder=-ssder
7062       endif
7063       return
7064       end subroutine splinthet
7065 !-----------------------------------------------------------------------------
7066       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7067 !      implicit none
7068       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
7069       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7070       a1=fprim0*delta/(f1-f0)
7071       a2=3.0d0-2.0d0*a1
7072       a3=a1-2.0d0
7073       ksi=(x-x0)/delta
7074       ksi2=ksi*ksi
7075       ksi3=ksi2*ksi
7076       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7077       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7078       return
7079       end subroutine spline1
7080 !-----------------------------------------------------------------------------
7081       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7082 !      implicit none
7083       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
7084       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7085       ksi=(x-x0)/delta
7086       ksi2=ksi*ksi
7087       ksi3=ksi2*ksi
7088       a1=fprim0x*delta
7089       a2=3*(f1x-f0x)-2*fprim0x*delta
7090       a3=fprim0x*delta-2*(f1x-f0x)
7091       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7092       return
7093       end subroutine spline2
7094 !-----------------------------------------------------------------------------
7095 #ifdef CRYST_TOR
7096 !-----------------------------------------------------------------------------
7097       subroutine etor(etors,edihcnstr)
7098 !      implicit real*8 (a-h,o-z)
7099 !      include 'DIMENSIONS'
7100 !      include 'COMMON.VAR'
7101 !      include 'COMMON.GEO'
7102 !      include 'COMMON.LOCAL'
7103 !      include 'COMMON.TORSION'
7104 !      include 'COMMON.INTERACT'
7105 !      include 'COMMON.DERIV'
7106 !      include 'COMMON.CHAIN'
7107 !      include 'COMMON.NAMES'
7108 !      include 'COMMON.IOUNITS'
7109 !      include 'COMMON.FFIELD'
7110 !      include 'COMMON.TORCNSTR'
7111 !      include 'COMMON.CONTROL'
7112       real(kind=8) :: etors,edihcnstr
7113       logical :: lprn
7114 !el local variables
7115       integer :: i,j,
7116       real(kind=8) :: phii,fac,etors_ii
7117
7118 ! Set lprn=.true. for debugging
7119       lprn=.false.
7120 !      lprn=.true.
7121       etors=0.0D0
7122       do i=iphi_start,iphi_end
7123       etors_ii=0.0D0
7124         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7125             .or. itype(i,1).eq.ntyp1) cycle
7126         itori=itortyp(itype(i-2,1))
7127         itori1=itortyp(itype(i-1,1))
7128         phii=phi(i)
7129         gloci=0.0D0
7130 ! Proline-Proline pair is a special case...
7131         if (itori.eq.3 .and. itori1.eq.3) then
7132           if (phii.gt.-dwapi3) then
7133             cosphi=dcos(3*phii)
7134             fac=1.0D0/(1.0D0-cosphi)
7135             etorsi=v1(1,3,3)*fac
7136             etorsi=etorsi+etorsi
7137             etors=etors+etorsi-v1(1,3,3)
7138             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7139             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7140           endif
7141           do j=1,3
7142             v1ij=v1(j+1,itori,itori1)
7143             v2ij=v2(j+1,itori,itori1)
7144             cosphi=dcos(j*phii)
7145             sinphi=dsin(j*phii)
7146             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7147             if (energy_dec) etors_ii=etors_ii+ &
7148                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7149             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7150           enddo
7151         else
7152           do j=1,nterm_old
7153             v1ij=v1(j,itori,itori1)
7154             v2ij=v2(j,itori,itori1)
7155             cosphi=dcos(j*phii)
7156             sinphi=dsin(j*phii)
7157             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7158             if (energy_dec) etors_ii=etors_ii+ &
7159                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7160             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7161           enddo
7162         endif
7163         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7164              'etor',i,etors_ii
7165         if (lprn) &
7166         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7167         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7168         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7169         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7170 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7171       enddo
7172 ! 6/20/98 - dihedral angle constraints
7173       edihcnstr=0.0d0
7174       do i=1,ndih_constr
7175         itori=idih_constr(i)
7176         phii=phi(itori)
7177         difi=phii-phi0(i)
7178         if (difi.gt.drange(i)) then
7179           difi=difi-drange(i)
7180           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7181           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7182         else if (difi.lt.-drange(i)) then
7183           difi=difi+drange(i)
7184           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7185           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7186         endif
7187 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7188 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7189       enddo
7190 !      write (iout,*) 'edihcnstr',edihcnstr
7191       return
7192       end subroutine etor
7193 !-----------------------------------------------------------------------------
7194       subroutine etor_d(etors_d)
7195       real(kind=8) :: etors_d
7196       etors_d=0.0d0
7197       return
7198       end subroutine etor_d
7199 #else
7200 !-----------------------------------------------------------------------------
7201       subroutine etor(etors)
7202 !      implicit real*8 (a-h,o-z)
7203 !      include 'DIMENSIONS'
7204 !      include 'COMMON.VAR'
7205 !      include 'COMMON.GEO'
7206 !      include 'COMMON.LOCAL'
7207 !      include 'COMMON.TORSION'
7208 !      include 'COMMON.INTERACT'
7209 !      include 'COMMON.DERIV'
7210 !      include 'COMMON.CHAIN'
7211 !      include 'COMMON.NAMES'
7212 !      include 'COMMON.IOUNITS'
7213 !      include 'COMMON.FFIELD'
7214 !      include 'COMMON.TORCNSTR'
7215 !      include 'COMMON.CONTROL'
7216       real(kind=8) :: etors,edihcnstr
7217       logical :: lprn
7218 !el local variables
7219       integer :: i,j,iblock,itori,itori1
7220       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7221                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
7222 ! Set lprn=.true. for debugging
7223       lprn=.false.
7224 !     lprn=.true.
7225       etors=0.0D0
7226       do i=iphi_start,iphi_end
7227         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7228              .or. itype(i-3,1).eq.ntyp1 &
7229              .or. itype(i,1).eq.ntyp1) cycle
7230         etors_ii=0.0D0
7231          if (iabs(itype(i,1)).eq.20) then
7232          iblock=2
7233          else
7234          iblock=1
7235          endif
7236         itori=itortyp(itype(i-2,1))
7237         itori1=itortyp(itype(i-1,1))
7238         phii=phi(i)
7239         gloci=0.0D0
7240 ! Regular cosine and sine terms
7241         do j=1,nterm(itori,itori1,iblock)
7242           v1ij=v1(j,itori,itori1,iblock)
7243           v2ij=v2(j,itori,itori1,iblock)
7244           cosphi=dcos(j*phii)
7245           sinphi=dsin(j*phii)
7246           etors=etors+v1ij*cosphi+v2ij*sinphi
7247           if (energy_dec) etors_ii=etors_ii+ &
7248                      v1ij*cosphi+v2ij*sinphi
7249           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7250         enddo
7251 ! Lorentz terms
7252 !                         v1
7253 !  E = SUM ----------------------------------- - v1
7254 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7255 !
7256         cosphi=dcos(0.5d0*phii)
7257         sinphi=dsin(0.5d0*phii)
7258         do j=1,nlor(itori,itori1,iblock)
7259           vl1ij=vlor1(j,itori,itori1)
7260           vl2ij=vlor2(j,itori,itori1)
7261           vl3ij=vlor3(j,itori,itori1)
7262           pom=vl2ij*cosphi+vl3ij*sinphi
7263           pom1=1.0d0/(pom*pom+1.0d0)
7264           etors=etors+vl1ij*pom1
7265           if (energy_dec) etors_ii=etors_ii+ &
7266                      vl1ij*pom1
7267           pom=-pom*pom1*pom1
7268           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7269         enddo
7270 ! Subtract the constant term
7271         etors=etors-v0(itori,itori1,iblock)
7272           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7273                'etor',i,etors_ii-v0(itori,itori1,iblock)
7274         if (lprn) &
7275         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7276         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7277         (v1(j,itori,itori1,iblock),j=1,6),&
7278         (v2(j,itori,itori1,iblock),j=1,6)
7279         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7280 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7281       enddo
7282 ! 6/20/98 - dihedral angle constraints
7283       return
7284       end subroutine etor
7285 !C The rigorous attempt to derive energy function
7286 !-------------------------------------------------------------------------------------------
7287       subroutine etor_kcc(etors)
7288       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7289       real(kind=8) :: etors,glocig,glocit1,glocit2,sinthet1,&
7290        sinthet2,costhet1,costhet2,sint1t2,sint1t2n,phii,sinphi,cosphi,&
7291        sint1t2n1,sumvalc,gradvalct1,gradvalct2,sumvals,gradvalst1,&
7292        gradvalst2,etori
7293       logical lprn
7294       integer :: i,j,itori,itori1,nval,k,l
7295
7296       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7297       etors=0.0D0
7298       do i=iphi_start,iphi_end
7299 !C ANY TWO ARE DUMMY ATOMS in row CYCLE
7300 !c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7301 !c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7302 !c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7303         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7304            .or. itype(i,1).eq.ntyp1 .or. itype(i-3,1).eq.ntyp1) cycle
7305         itori=itortyp(itype(i-2,1))
7306         itori1=itortyp(itype(i-1,1))
7307         phii=phi(i)
7308         glocig=0.0D0
7309         glocit1=0.0d0
7310         glocit2=0.0d0
7311 !C to avoid multiple devision by 2
7312 !c        theti22=0.5d0*theta(i)
7313 !C theta 12 is the theta_1 /2
7314 !C theta 22 is theta_2 /2
7315 !c        theti12=0.5d0*theta(i-1)
7316 !C and appropriate sinus function
7317         sinthet1=dsin(theta(i-1))
7318         sinthet2=dsin(theta(i))
7319         costhet1=dcos(theta(i-1))
7320         costhet2=dcos(theta(i))
7321 !C to speed up lets store its mutliplication
7322         sint1t2=sinthet2*sinthet1
7323         sint1t2n=1.0d0
7324 !C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7325 !C +d_n*sin(n*gamma)) *
7326 !C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7327 !C we have two sum 1) Non-Chebyshev which is with n and gamma
7328         nval=nterm_kcc_Tb(itori,itori1)
7329         c1(0)=0.0d0
7330         c2(0)=0.0d0
7331         c1(1)=1.0d0
7332         c2(1)=1.0d0
7333         do j=2,nval
7334           c1(j)=c1(j-1)*costhet1
7335           c2(j)=c2(j-1)*costhet2
7336         enddo
7337         etori=0.0d0
7338
7339        do j=1,nterm_kcc(itori,itori1)
7340           cosphi=dcos(j*phii)
7341           sinphi=dsin(j*phii)
7342           sint1t2n1=sint1t2n
7343           sint1t2n=sint1t2n*sint1t2
7344           sumvalc=0.0d0
7345           gradvalct1=0.0d0
7346           gradvalct2=0.0d0
7347           do k=1,nval
7348             do l=1,nval
7349               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7350               gradvalct1=gradvalct1+ &
7351                 (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7352               gradvalct2=gradvalct2+ &
7353                 (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7354             enddo
7355           enddo
7356           gradvalct1=-gradvalct1*sinthet1
7357           gradvalct2=-gradvalct2*sinthet2
7358           sumvals=0.0d0
7359           gradvalst1=0.0d0
7360           gradvalst2=0.0d0
7361           do k=1,nval
7362             do l=1,nval
7363               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7364               gradvalst1=gradvalst1+ &
7365                 (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7366               gradvalst2=gradvalst2+ &
7367                 (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7368             enddo
7369           enddo
7370           gradvalst1=-gradvalst1*sinthet1
7371           gradvalst2=-gradvalst2*sinthet2
7372           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7373           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7374 !C glocig is the gradient local i site in gamma
7375           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7376 !C now gradient over theta_1
7377          glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)&
7378         +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7379          glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)&
7380         +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7381         enddo ! j
7382         etors=etors+etori
7383         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7384 !C derivative over theta1
7385         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7386 !C now derivative over theta2
7387         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7388         if (lprn) then
7389          write (iout,*) i-2,i-1,itype(i-2,1),itype(i-1,1),itori,itori1,&
7390             theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7391           write (iout,*) "c1",(c1(k),k=0,nval), &
7392          " c2",(c2(k),k=0,nval)
7393         endif
7394       enddo
7395       return
7396        end  subroutine etor_kcc
7397 !------------------------------------------------------------------------------
7398
7399         subroutine etor_constr(edihcnstr)
7400       real(kind=8) :: etors,edihcnstr
7401       logical :: lprn
7402 !el local variables
7403       integer :: i,j,iblock,itori,itori1
7404       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7405                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom,&
7406                    gaudih_i,gauder_i,s,cos_i,dexpcos_i
7407
7408       if (raw_psipred) then
7409         do i=idihconstr_start,idihconstr_end
7410           itori=idih_constr(i)
7411           phii=phi(itori)
7412           gaudih_i=vpsipred(1,i)
7413           gauder_i=0.0d0
7414           do j=1,2
7415             s = sdihed(j,i)
7416             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7417             dexpcos_i=dexp(-cos_i*cos_i)
7418             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7419           gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i)) &
7420                  *cos_i*dexpcos_i/s**2
7421           enddo
7422           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7423           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7424           if (energy_dec) &
7425           write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)') &
7426           i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),&
7427           phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),&
7428           phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,&
7429           -wdihc*dlog(gaudih_i)
7430         enddo
7431       else
7432
7433       do i=idihconstr_start,idihconstr_end
7434         itori=idih_constr(i)
7435         phii=phi(itori)
7436         difi=pinorm(phii-phi0(i))
7437         if (difi.gt.drange(i)) then
7438           difi=difi-drange(i)
7439           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7440           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7441         else if (difi.lt.-drange(i)) then
7442           difi=difi+drange(i)
7443           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7444           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7445         else
7446           difi=0.0
7447         endif
7448       enddo
7449
7450       endif
7451
7452       return
7453
7454       end subroutine etor_constr
7455 !-----------------------------------------------------------------------------
7456       subroutine etor_d(etors_d)
7457 ! 6/23/01 Compute double torsional energy
7458 !      implicit real*8 (a-h,o-z)
7459 !      include 'DIMENSIONS'
7460 !      include 'COMMON.VAR'
7461 !      include 'COMMON.GEO'
7462 !      include 'COMMON.LOCAL'
7463 !      include 'COMMON.TORSION'
7464 !      include 'COMMON.INTERACT'
7465 !      include 'COMMON.DERIV'
7466 !      include 'COMMON.CHAIN'
7467 !      include 'COMMON.NAMES'
7468 !      include 'COMMON.IOUNITS'
7469 !      include 'COMMON.FFIELD'
7470 !      include 'COMMON.TORCNSTR'
7471       real(kind=8) :: etors_d,etors_d_ii
7472       logical :: lprn
7473 !el local variables
7474       integer :: i,j,k,l,itori,itori1,itori2,iblock
7475       real(kind=8) :: phii,phii1,gloci1,gloci2,&
7476                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
7477                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
7478                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
7479 ! Set lprn=.true. for debugging
7480       lprn=.false.
7481 !     lprn=.true.
7482       etors_d=0.0D0
7483 !      write(iout,*) "a tu??"
7484       do i=iphid_start,iphid_end
7485         etors_d_ii=0.0D0
7486         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7487             .or. itype(i-3,1).eq.ntyp1 &
7488             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
7489         itori=itortyp(itype(i-2,1))
7490         itori1=itortyp(itype(i-1,1))
7491         itori2=itortyp(itype(i,1))
7492         phii=phi(i)
7493         phii1=phi(i+1)
7494         gloci1=0.0D0
7495         gloci2=0.0D0
7496         iblock=1
7497         if (iabs(itype(i+1,1)).eq.20) iblock=2
7498
7499 ! Regular cosine and sine terms
7500         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7501           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7502           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7503           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7504           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7505           cosphi1=dcos(j*phii)
7506           sinphi1=dsin(j*phii)
7507           cosphi2=dcos(j*phii1)
7508           sinphi2=dsin(j*phii1)
7509           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
7510            v2cij*cosphi2+v2sij*sinphi2
7511           if (energy_dec) etors_d_ii=etors_d_ii+ &
7512            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7513           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7514           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7515         enddo
7516         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7517           do l=1,k-1
7518             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7519             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7520             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7521             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7522             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7523             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7524             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7525             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7526             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7527               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7528             if (energy_dec) etors_d_ii=etors_d_ii+ &
7529               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7530               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7531             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
7532               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7533             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
7534               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7535           enddo
7536         enddo
7537         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7538                             'etor_d',i,etors_d_ii
7539         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7540         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7541       enddo
7542       return
7543       end subroutine etor_d
7544 #endif
7545
7546       subroutine ebend_kcc(etheta)
7547       logical lprn
7548       double precision thybt1(maxang_kcc),etheta
7549       integer :: i,iti,j,ihelp
7550       real (kind=8) :: sinthet,costhet,sumth1thyb,gradthybt1
7551 !C Set lprn=.true. for debugging
7552       lprn=energy_dec
7553 !c     lprn=.true.
7554 !C      print *,"wchodze kcc"
7555       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7556       etheta=0.0D0
7557       do i=ithet_start,ithet_end
7558 !c        print *,i,itype(i-1),itype(i),itype(i-2)
7559         if ((itype(i-1,1).eq.ntyp1).or.itype(i-2,1).eq.ntyp1 &
7560        .or.itype(i,1).eq.ntyp1) cycle
7561         iti=iabs(itortyp(itype(i-1,1)))
7562         sinthet=dsin(theta(i))
7563         costhet=dcos(theta(i))
7564         do j=1,nbend_kcc_Tb(iti)
7565           thybt1(j)=v1bend_chyb(j,iti)
7566         enddo
7567         sumth1thyb=v1bend_chyb(0,iti)+ &
7568          tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7569         if (lprn) write (iout,*) i-1,itype(i-1,1),iti,theta(i)*rad2deg,&
7570          sumth1thyb
7571         ihelp=nbend_kcc_Tb(iti)-1
7572         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
7573         etheta=etheta+sumth1thyb
7574 !C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7575         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
7576       enddo
7577       return
7578       end subroutine ebend_kcc
7579 !c------------
7580 !c-------------------------------------------------------------------------------------
7581       subroutine etheta_constr(ethetacnstr)
7582       real (kind=8) :: ethetacnstr,thetiii,difi
7583       integer :: i,itheta
7584       ethetacnstr=0.0d0
7585 !C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7586       do i=ithetaconstr_start,ithetaconstr_end
7587         itheta=itheta_constr(i)
7588         thetiii=theta(itheta)
7589         difi=pinorm(thetiii-theta_constr0(i))
7590         if (difi.gt.theta_drange(i)) then
7591           difi=difi-theta_drange(i)
7592           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7593           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
7594          +for_thet_constr(i)*difi**3
7595         else if (difi.lt.-drange(i)) then
7596           difi=difi+drange(i)
7597           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7598           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
7599           +for_thet_constr(i)*difi**3
7600         else
7601           difi=0.0
7602         endif
7603        if (energy_dec) then
7604         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",&
7605          i,itheta,rad2deg*thetiii,&
7606          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),&
7607          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,&
7608          gloc(itheta+nphi-2,icg)
7609         endif
7610       enddo
7611       return
7612       end subroutine etheta_constr
7613
7614 !-----------------------------------------------------------------------------
7615       subroutine eback_sc_corr(esccor)
7616 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
7617 !        conformational states; temporarily implemented as differences
7618 !        between UNRES torsional potentials (dependent on three types of
7619 !        residues) and the torsional potentials dependent on all 20 types
7620 !        of residues computed from AM1  energy surfaces of terminally-blocked
7621 !        amino-acid residues.
7622 !      implicit real*8 (a-h,o-z)
7623 !      include 'DIMENSIONS'
7624 !      include 'COMMON.VAR'
7625 !      include 'COMMON.GEO'
7626 !      include 'COMMON.LOCAL'
7627 !      include 'COMMON.TORSION'
7628 !      include 'COMMON.SCCOR'
7629 !      include 'COMMON.INTERACT'
7630 !      include 'COMMON.DERIV'
7631 !      include 'COMMON.CHAIN'
7632 !      include 'COMMON.NAMES'
7633 !      include 'COMMON.IOUNITS'
7634 !      include 'COMMON.FFIELD'
7635 !      include 'COMMON.CONTROL'
7636       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
7637                    cosphi,sinphi
7638       logical :: lprn
7639       integer :: i,interty,j,isccori,isccori1,intertyp
7640 ! Set lprn=.true. for debugging
7641       lprn=.false.
7642 !      lprn=.true.
7643 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7644       esccor=0.0D0
7645       do i=itau_start,itau_end
7646         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
7647         esccor_ii=0.0D0
7648         isccori=isccortyp(itype(i-2,1))
7649         isccori1=isccortyp(itype(i-1,1))
7650
7651 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7652         phii=phi(i)
7653         do intertyp=1,3 !intertyp
7654          esccor_ii=0.0D0
7655 !c Added 09 May 2012 (Adasko)
7656 !c  Intertyp means interaction type of backbone mainchain correlation:
7657 !   1 = SC...Ca...Ca...Ca
7658 !   2 = Ca...Ca...Ca...SC
7659 !   3 = SC...Ca...Ca...SCi
7660         gloci=0.0D0
7661         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
7662             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
7663             (itype(i-1,1).eq.ntyp1))) &
7664           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
7665            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
7666            .or.(itype(i,1).eq.ntyp1))) &
7667           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
7668             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
7669             (itype(i-3,1).eq.ntyp1)))) cycle
7670         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
7671         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
7672        cycle
7673        do j=1,nterm_sccor(isccori,isccori1)
7674           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7675           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7676           cosphi=dcos(j*tauangle(intertyp,i))
7677           sinphi=dsin(j*tauangle(intertyp,i))
7678           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7679           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7680           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7681         enddo
7682         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
7683                                 'esccor',i,intertyp,esccor_ii
7684 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7685         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7686         if (lprn) &
7687         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7688         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
7689         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
7690         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7691         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7692        enddo !intertyp
7693       enddo
7694
7695       return
7696       end subroutine eback_sc_corr
7697 !-----------------------------------------------------------------------------
7698       subroutine multibody(ecorr)
7699 ! This subroutine calculates multi-body contributions to energy following
7700 ! the idea of Skolnick et al. If side chains I and J make a contact and
7701 ! at the same time side chains I+1 and J+1 make a contact, an extra
7702 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7703 !      implicit real*8 (a-h,o-z)
7704 !      include 'DIMENSIONS'
7705 !      include 'COMMON.IOUNITS'
7706 !      include 'COMMON.DERIV'
7707 !      include 'COMMON.INTERACT'
7708 !      include 'COMMON.CONTACTS'
7709       real(kind=8),dimension(3) :: gx,gx1
7710       logical :: lprn
7711       real(kind=8) :: ecorr
7712       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
7713 ! Set lprn=.true. for debugging
7714       lprn=.false.
7715
7716       if (lprn) then
7717         write (iout,'(a)') 'Contact function values:'
7718         do i=nnt,nct-2
7719           write (iout,'(i2,20(1x,i2,f10.5))') &
7720               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7721         enddo
7722       endif
7723       ecorr=0.0D0
7724
7725 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7726 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7727       do i=nnt,nct
7728         do j=1,3
7729           gradcorr(j,i)=0.0D0
7730           gradxorr(j,i)=0.0D0
7731         enddo
7732       enddo
7733       do i=nnt,nct-2
7734
7735         DO ISHIFT = 3,4
7736
7737         i1=i+ishift
7738         num_conti=num_cont(i)
7739         num_conti1=num_cont(i1)
7740         do jj=1,num_conti
7741           j=jcont(jj,i)
7742           do kk=1,num_conti1
7743             j1=jcont(kk,i1)
7744             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7745 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7746 !d   &                   ' ishift=',ishift
7747 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7748 ! The system gains extra energy.
7749               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7750             endif   ! j1==j+-ishift
7751           enddo     ! kk
7752         enddo       ! jj
7753
7754         ENDDO ! ISHIFT
7755
7756       enddo         ! i
7757       return
7758       end subroutine multibody
7759 !-----------------------------------------------------------------------------
7760       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7761 !      implicit real*8 (a-h,o-z)
7762 !      include 'DIMENSIONS'
7763 !      include 'COMMON.IOUNITS'
7764 !      include 'COMMON.DERIV'
7765 !      include 'COMMON.INTERACT'
7766 !      include 'COMMON.CONTACTS'
7767       real(kind=8),dimension(3) :: gx,gx1
7768       logical :: lprn
7769       integer :: i,j,k,l,jj,kk,m,ll
7770       real(kind=8) :: eij,ekl
7771       lprn=.false.
7772       eij=facont(jj,i)
7773       ekl=facont(kk,k)
7774 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7775 ! Calculate the multi-body contribution to energy.
7776 ! Calculate multi-body contributions to the gradient.
7777 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7778 !d   & k,l,(gacont(m,kk,k),m=1,3)
7779       do m=1,3
7780         gx(m) =ekl*gacont(m,jj,i)
7781         gx1(m)=eij*gacont(m,kk,k)
7782         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7783         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7784         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7785         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7786       enddo
7787       do m=i,j-1
7788         do ll=1,3
7789           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7790         enddo
7791       enddo
7792       do m=k,l-1
7793         do ll=1,3
7794           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7795         enddo
7796       enddo
7797       esccorr=-eij*ekl
7798       return
7799       end function esccorr
7800 !-----------------------------------------------------------------------------
7801       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7802 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7803 !      implicit real*8 (a-h,o-z)
7804 !      include 'DIMENSIONS'
7805 !      include 'COMMON.IOUNITS'
7806 #ifdef MPI
7807       include "mpif.h"
7808 !      integer :: maxconts !max_cont=maxconts  =nres/4
7809       integer,parameter :: max_dim=26
7810       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7811       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7812 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7813 !el      common /przechowalnia/ zapas
7814       integer :: status(MPI_STATUS_SIZE)
7815       integer,dimension((nres/4)*2) :: req !maxconts*2
7816       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7817 #endif
7818 !      include 'COMMON.SETUP'
7819 !      include 'COMMON.FFIELD'
7820 !      include 'COMMON.DERIV'
7821 !      include 'COMMON.INTERACT'
7822 !      include 'COMMON.CONTACTS'
7823 !      include 'COMMON.CONTROL'
7824 !      include 'COMMON.LOCAL'
7825       real(kind=8),dimension(3) :: gx,gx1
7826       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7827       logical :: lprn,ldone
7828 !el local variables
7829       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7830               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7831
7832 ! Set lprn=.true. for debugging
7833       lprn=.false.
7834 #ifdef MPI
7835 !      maxconts=nres/4
7836       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7837       n_corr=0
7838       n_corr1=0
7839       if (nfgtasks.le.1) goto 30
7840       if (lprn) then
7841         write (iout,'(a)') 'Contact function values before RECEIVE:'
7842         do i=nnt,nct-2
7843           write (iout,'(2i3,50(1x,i2,f5.2))') &
7844           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7845           j=1,num_cont_hb(i))
7846         enddo
7847       endif
7848       call flush(iout)
7849       do i=1,ntask_cont_from
7850         ncont_recv(i)=0
7851       enddo
7852       do i=1,ntask_cont_to
7853         ncont_sent(i)=0
7854       enddo
7855 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7856 !     & ntask_cont_to
7857 ! Make the list of contacts to send to send to other procesors
7858 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7859 !      call flush(iout)
7860       do i=iturn3_start,iturn3_end
7861 !        write (iout,*) "make contact list turn3",i," num_cont",
7862 !     &    num_cont_hb(i)
7863         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7864       enddo
7865       do i=iturn4_start,iturn4_end
7866 !        write (iout,*) "make contact list turn4",i," num_cont",
7867 !     &   num_cont_hb(i)
7868         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7869       enddo
7870       do ii=1,nat_sent
7871         i=iat_sent(ii)
7872 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7873 !     &    num_cont_hb(i)
7874         do j=1,num_cont_hb(i)
7875         do k=1,4
7876           jjc=jcont_hb(j,i)
7877           iproc=iint_sent_local(k,jjc,ii)
7878 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7879           if (iproc.gt.0) then
7880             ncont_sent(iproc)=ncont_sent(iproc)+1
7881             nn=ncont_sent(iproc)
7882             zapas(1,nn,iproc)=i
7883             zapas(2,nn,iproc)=jjc
7884             zapas(3,nn,iproc)=facont_hb(j,i)
7885             zapas(4,nn,iproc)=ees0p(j,i)
7886             zapas(5,nn,iproc)=ees0m(j,i)
7887             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7888             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7889             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7890             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7891             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7892             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7893             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7894             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7895             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7896             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7897             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7898             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7899             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7900             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7901             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7902             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7903             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7904             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7905             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7906             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7907             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7908           endif
7909         enddo
7910         enddo
7911       enddo
7912       if (lprn) then
7913       write (iout,*) &
7914         "Numbers of contacts to be sent to other processors",&
7915         (ncont_sent(i),i=1,ntask_cont_to)
7916       write (iout,*) "Contacts sent"
7917       do ii=1,ntask_cont_to
7918         nn=ncont_sent(ii)
7919         iproc=itask_cont_to(ii)
7920         write (iout,*) nn," contacts to processor",iproc,&
7921          " of CONT_TO_COMM group"
7922         do i=1,nn
7923           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7924         enddo
7925       enddo
7926       call flush(iout)
7927       endif
7928       CorrelType=477
7929       CorrelID=fg_rank+1
7930       CorrelType1=478
7931       CorrelID1=nfgtasks+fg_rank+1
7932       ireq=0
7933 ! Receive the numbers of needed contacts from other processors
7934       do ii=1,ntask_cont_from
7935         iproc=itask_cont_from(ii)
7936         ireq=ireq+1
7937         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7938           FG_COMM,req(ireq),IERR)
7939       enddo
7940 !      write (iout,*) "IRECV ended"
7941 !      call flush(iout)
7942 ! Send the number of contacts needed by other processors
7943       do ii=1,ntask_cont_to
7944         iproc=itask_cont_to(ii)
7945         ireq=ireq+1
7946         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7947           FG_COMM,req(ireq),IERR)
7948       enddo
7949 !      write (iout,*) "ISEND ended"
7950 !      write (iout,*) "number of requests (nn)",ireq
7951       call flush(iout)
7952       if (ireq.gt.0) &
7953         call MPI_Waitall(ireq,req,status_array,ierr)
7954 !      write (iout,*)
7955 !     &  "Numbers of contacts to be received from other processors",
7956 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7957 !      call flush(iout)
7958 ! Receive contacts
7959       ireq=0
7960       do ii=1,ntask_cont_from
7961         iproc=itask_cont_from(ii)
7962         nn=ncont_recv(ii)
7963 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7964 !     &   " of CONT_TO_COMM group"
7965         call flush(iout)
7966         if (nn.gt.0) then
7967           ireq=ireq+1
7968           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7969           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7970 !          write (iout,*) "ireq,req",ireq,req(ireq)
7971         endif
7972       enddo
7973 ! Send the contacts to processors that need them
7974       do ii=1,ntask_cont_to
7975         iproc=itask_cont_to(ii)
7976         nn=ncont_sent(ii)
7977 !        write (iout,*) nn," contacts to processor",iproc,
7978 !     &   " of CONT_TO_COMM group"
7979         if (nn.gt.0) then
7980           ireq=ireq+1
7981           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7982             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7983 !          write (iout,*) "ireq,req",ireq,req(ireq)
7984 !          do i=1,nn
7985 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7986 !          enddo
7987         endif
7988       enddo
7989 !      write (iout,*) "number of requests (contacts)",ireq
7990 !      write (iout,*) "req",(req(i),i=1,4)
7991 !      call flush(iout)
7992       if (ireq.gt.0) &
7993        call MPI_Waitall(ireq,req,status_array,ierr)
7994       do iii=1,ntask_cont_from
7995         iproc=itask_cont_from(iii)
7996         nn=ncont_recv(iii)
7997         if (lprn) then
7998         write (iout,*) "Received",nn," contacts from processor",iproc,&
7999          " of CONT_FROM_COMM group"
8000         call flush(iout)
8001         do i=1,nn
8002           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8003         enddo
8004         call flush(iout)
8005         endif
8006         do i=1,nn
8007           ii=zapas_recv(1,i,iii)
8008 ! Flag the received contacts to prevent double-counting
8009           jj=-zapas_recv(2,i,iii)
8010 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8011 !          call flush(iout)
8012           nnn=num_cont_hb(ii)+1
8013           num_cont_hb(ii)=nnn
8014           jcont_hb(nnn,ii)=jj
8015           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8016           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8017           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8018           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8019           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8020           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8021           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8022           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8023           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8024           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8025           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8026           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8027           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8028           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8029           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8030           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8031           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8032           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8033           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8034           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8035           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8036           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8037           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8038           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8039         enddo
8040       enddo
8041       call flush(iout)
8042       if (lprn) then
8043         write (iout,'(a)') 'Contact function values after receive:'
8044         do i=nnt,nct-2
8045           write (iout,'(2i3,50(1x,i3,f5.2))') &
8046           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8047           j=1,num_cont_hb(i))
8048         enddo
8049         call flush(iout)
8050       endif
8051    30 continue
8052 #endif
8053       if (lprn) then
8054         write (iout,'(a)') 'Contact function values:'
8055         do i=nnt,nct-2
8056           write (iout,'(2i3,50(1x,i3,f5.2))') &
8057           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8058           j=1,num_cont_hb(i))
8059         enddo
8060       endif
8061       ecorr=0.0D0
8062
8063 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8064 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8065 ! Remove the loop below after debugging !!!
8066       do i=nnt,nct
8067         do j=1,3
8068           gradcorr(j,i)=0.0D0
8069           gradxorr(j,i)=0.0D0
8070         enddo
8071       enddo
8072 ! Calculate the local-electrostatic correlation terms
8073       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8074         i1=i+1
8075         num_conti=num_cont_hb(i)
8076         num_conti1=num_cont_hb(i+1)
8077         do jj=1,num_conti
8078           j=jcont_hb(jj,i)
8079           jp=iabs(j)
8080           do kk=1,num_conti1
8081             j1=jcont_hb(kk,i1)
8082             jp1=iabs(j1)
8083 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
8084 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
8085             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8086                 .or. j.lt.0 .and. j1.gt.0) .and. &
8087                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8088 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8089 ! The system gains extra energy.
8090               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8091               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
8092                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8093               n_corr=n_corr+1
8094             else if (j1.eq.j) then
8095 ! Contacts I-J and I-(J+1) occur simultaneously.
8096 ! The system loses extra energy.
8097 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8098             endif
8099           enddo ! kk
8100           do kk=1,num_conti
8101             j1=jcont_hb(kk,i)
8102 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8103 !    &         ' jj=',jj,' kk=',kk
8104             if (j1.eq.j+1) then
8105 ! Contacts I-J and (I+1)-J occur simultaneously.
8106 ! The system loses extra energy.
8107 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8108             endif ! j1==j+1
8109           enddo ! kk
8110         enddo ! jj
8111       enddo ! i
8112       return
8113       end subroutine multibody_hb
8114 !-----------------------------------------------------------------------------
8115       subroutine add_hb_contact(ii,jj,itask)
8116 !      implicit real*8 (a-h,o-z)
8117 !      include "DIMENSIONS"
8118 !      include "COMMON.IOUNITS"
8119 !      include "COMMON.CONTACTS"
8120 !      integer,parameter :: maxconts=nres/4
8121       integer,parameter :: max_dim=26
8122       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8123 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
8124 !      common /przechowalnia/ zapas
8125       integer :: i,j,ii,jj,iproc,nn,jjc
8126       integer,dimension(4) :: itask
8127 !      write (iout,*) "itask",itask
8128       do i=1,2
8129         iproc=itask(i)
8130         if (iproc.gt.0) then
8131           do j=1,num_cont_hb(ii)
8132             jjc=jcont_hb(j,ii)
8133 !            write (iout,*) "i",ii," j",jj," jjc",jjc
8134             if (jjc.eq.jj) then
8135               ncont_sent(iproc)=ncont_sent(iproc)+1
8136               nn=ncont_sent(iproc)
8137               zapas(1,nn,iproc)=ii
8138               zapas(2,nn,iproc)=jjc
8139               zapas(3,nn,iproc)=facont_hb(j,ii)
8140               zapas(4,nn,iproc)=ees0p(j,ii)
8141               zapas(5,nn,iproc)=ees0m(j,ii)
8142               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8143               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8144               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8145               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8146               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8147               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8148               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8149               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8150               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8151               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8152               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8153               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8154               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8155               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8156               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8157               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8158               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8159               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8160               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8161               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8162               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8163               exit
8164             endif
8165           enddo
8166         endif
8167       enddo
8168       return
8169       end subroutine add_hb_contact
8170 !-----------------------------------------------------------------------------
8171       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
8172 ! This subroutine calculates multi-body contributions to hydrogen-bonding
8173 !      implicit real*8 (a-h,o-z)
8174 !      include 'DIMENSIONS'
8175 !      include 'COMMON.IOUNITS'
8176       integer,parameter :: max_dim=70
8177 #ifdef MPI
8178       include "mpif.h"
8179 !      integer :: maxconts !max_cont=maxconts=nres/4
8180       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8181       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8182 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8183 !      common /przechowalnia/ zapas
8184       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
8185         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
8186         ierr,iii,nnn
8187 #endif
8188 !      include 'COMMON.SETUP'
8189 !      include 'COMMON.FFIELD'
8190 !      include 'COMMON.DERIV'
8191 !      include 'COMMON.LOCAL'
8192 !      include 'COMMON.INTERACT'
8193 !      include 'COMMON.CONTACTS'
8194 !      include 'COMMON.CHAIN'
8195 !      include 'COMMON.CONTROL'
8196       real(kind=8),dimension(3) :: gx,gx1
8197       integer,dimension(nres) :: num_cont_hb_old
8198       logical :: lprn,ldone
8199 !EL      double precision eello4,eello5,eelo6,eello_turn6
8200 !EL      external eello4,eello5,eello6,eello_turn6
8201 !el local variables
8202       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
8203               j1,jp1,i1,num_conti1
8204       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
8205       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
8206
8207 ! Set lprn=.true. for debugging
8208       lprn=.false.
8209       eturn6=0.0d0
8210 #ifdef MPI
8211 !      maxconts=nres/4
8212       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
8213       do i=1,nres
8214         num_cont_hb_old(i)=num_cont_hb(i)
8215       enddo
8216       n_corr=0
8217       n_corr1=0
8218       if (nfgtasks.le.1) goto 30
8219       if (lprn) then
8220         write (iout,'(a)') 'Contact function values before RECEIVE:'
8221         do i=nnt,nct-2
8222           write (iout,'(2i3,50(1x,i2,f5.2))') &
8223           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8224           j=1,num_cont_hb(i))
8225         enddo
8226       endif
8227       call flush(iout)
8228       do i=1,ntask_cont_from
8229         ncont_recv(i)=0
8230       enddo
8231       do i=1,ntask_cont_to
8232         ncont_sent(i)=0
8233       enddo
8234 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8235 !     & ntask_cont_to
8236 ! Make the list of contacts to send to send to other procesors
8237       do i=iturn3_start,iturn3_end
8238 !        write (iout,*) "make contact list turn3",i," num_cont",
8239 !     &    num_cont_hb(i)
8240         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8241       enddo
8242       do i=iturn4_start,iturn4_end
8243 !        write (iout,*) "make contact list turn4",i," num_cont",
8244 !     &   num_cont_hb(i)
8245         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8246       enddo
8247       do ii=1,nat_sent
8248         i=iat_sent(ii)
8249 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8250 !     &    num_cont_hb(i)
8251         do j=1,num_cont_hb(i)
8252         do k=1,4
8253           jjc=jcont_hb(j,i)
8254           iproc=iint_sent_local(k,jjc,ii)
8255 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8256           if (iproc.ne.0) then
8257             ncont_sent(iproc)=ncont_sent(iproc)+1
8258             nn=ncont_sent(iproc)
8259             zapas(1,nn,iproc)=i
8260             zapas(2,nn,iproc)=jjc
8261             zapas(3,nn,iproc)=d_cont(j,i)
8262             ind=3
8263             do kk=1,3
8264               ind=ind+1
8265               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8266             enddo
8267             do kk=1,2
8268               do ll=1,2
8269                 ind=ind+1
8270                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8271               enddo
8272             enddo
8273             do jj=1,5
8274               do kk=1,3
8275                 do ll=1,2
8276                   do mm=1,2
8277                     ind=ind+1
8278                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8279                   enddo
8280                 enddo
8281               enddo
8282             enddo
8283           endif
8284         enddo
8285         enddo
8286       enddo
8287       if (lprn) then
8288       write (iout,*) &
8289         "Numbers of contacts to be sent to other processors",&
8290         (ncont_sent(i),i=1,ntask_cont_to)
8291       write (iout,*) "Contacts sent"
8292       do ii=1,ntask_cont_to
8293         nn=ncont_sent(ii)
8294         iproc=itask_cont_to(ii)
8295         write (iout,*) nn," contacts to processor",iproc,&
8296          " of CONT_TO_COMM group"
8297         do i=1,nn
8298           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8299         enddo
8300       enddo
8301       call flush(iout)
8302       endif
8303       CorrelType=477
8304       CorrelID=fg_rank+1
8305       CorrelType1=478
8306       CorrelID1=nfgtasks+fg_rank+1
8307       ireq=0
8308 ! Receive the numbers of needed contacts from other processors
8309       do ii=1,ntask_cont_from
8310         iproc=itask_cont_from(ii)
8311         ireq=ireq+1
8312         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8313           FG_COMM,req(ireq),IERR)
8314       enddo
8315 !      write (iout,*) "IRECV ended"
8316 !      call flush(iout)
8317 ! Send the number of contacts needed by other processors
8318       do ii=1,ntask_cont_to
8319         iproc=itask_cont_to(ii)
8320         ireq=ireq+1
8321         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8322           FG_COMM,req(ireq),IERR)
8323       enddo
8324 !      write (iout,*) "ISEND ended"
8325 !      write (iout,*) "number of requests (nn)",ireq
8326       call flush(iout)
8327       if (ireq.gt.0) &
8328         call MPI_Waitall(ireq,req,status_array,ierr)
8329 !      write (iout,*)
8330 !     &  "Numbers of contacts to be received from other processors",
8331 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8332 !      call flush(iout)
8333 ! Receive contacts
8334       ireq=0
8335       do ii=1,ntask_cont_from
8336         iproc=itask_cont_from(ii)
8337         nn=ncont_recv(ii)
8338 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8339 !     &   " of CONT_TO_COMM group"
8340         call flush(iout)
8341         if (nn.gt.0) then
8342           ireq=ireq+1
8343           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
8344           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8345 !          write (iout,*) "ireq,req",ireq,req(ireq)
8346         endif
8347       enddo
8348 ! Send the contacts to processors that need them
8349       do ii=1,ntask_cont_to
8350         iproc=itask_cont_to(ii)
8351         nn=ncont_sent(ii)
8352 !        write (iout,*) nn," contacts to processor",iproc,
8353 !     &   " of CONT_TO_COMM group"
8354         if (nn.gt.0) then
8355           ireq=ireq+1
8356           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8357             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8358 !          write (iout,*) "ireq,req",ireq,req(ireq)
8359 !          do i=1,nn
8360 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8361 !          enddo
8362         endif
8363       enddo
8364 !      write (iout,*) "number of requests (contacts)",ireq
8365 !      write (iout,*) "req",(req(i),i=1,4)
8366 !      call flush(iout)
8367       if (ireq.gt.0) &
8368        call MPI_Waitall(ireq,req,status_array,ierr)
8369       do iii=1,ntask_cont_from
8370         iproc=itask_cont_from(iii)
8371         nn=ncont_recv(iii)
8372         if (lprn) then
8373         write (iout,*) "Received",nn," contacts from processor",iproc,&
8374          " of CONT_FROM_COMM group"
8375         call flush(iout)
8376         do i=1,nn
8377           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8378         enddo
8379         call flush(iout)
8380         endif
8381         do i=1,nn
8382           ii=zapas_recv(1,i,iii)
8383 ! Flag the received contacts to prevent double-counting
8384           jj=-zapas_recv(2,i,iii)
8385 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8386 !          call flush(iout)
8387           nnn=num_cont_hb(ii)+1
8388           num_cont_hb(ii)=nnn
8389           jcont_hb(nnn,ii)=jj
8390           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8391           ind=3
8392           do kk=1,3
8393             ind=ind+1
8394             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8395           enddo
8396           do kk=1,2
8397             do ll=1,2
8398               ind=ind+1
8399               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8400             enddo
8401           enddo
8402           do jj=1,5
8403             do kk=1,3
8404               do ll=1,2
8405                 do mm=1,2
8406                   ind=ind+1
8407                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8408                 enddo
8409               enddo
8410             enddo
8411           enddo
8412         enddo
8413       enddo
8414       call flush(iout)
8415       if (lprn) then
8416         write (iout,'(a)') 'Contact function values after receive:'
8417         do i=nnt,nct-2
8418           write (iout,'(2i3,50(1x,i3,5f6.3))') &
8419           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8420           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8421         enddo
8422         call flush(iout)
8423       endif
8424    30 continue
8425 #endif
8426       if (lprn) then
8427         write (iout,'(a)') 'Contact function values:'
8428         do i=nnt,nct-2
8429           write (iout,'(2i3,50(1x,i2,5f6.3))') &
8430           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8431           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8432         enddo
8433       endif
8434       ecorr=0.0D0
8435       ecorr5=0.0d0
8436       ecorr6=0.0d0
8437
8438 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8439 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8440 ! Remove the loop below after debugging !!!
8441       do i=nnt,nct
8442         do j=1,3
8443           gradcorr(j,i)=0.0D0
8444           gradxorr(j,i)=0.0D0
8445         enddo
8446       enddo
8447 ! Calculate the dipole-dipole interaction energies
8448       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8449       do i=iatel_s,iatel_e+1
8450         num_conti=num_cont_hb(i)
8451         do jj=1,num_conti
8452           j=jcont_hb(jj,i)
8453 #ifdef MOMENT
8454           call dipole(i,j,jj)
8455 #endif
8456         enddo
8457       enddo
8458       endif
8459 ! Calculate the local-electrostatic correlation terms
8460 !                write (iout,*) "gradcorr5 in eello5 before loop"
8461 !                do iii=1,nres
8462 !                  write (iout,'(i5,3f10.5)')
8463 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8464 !                enddo
8465       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8466 !        write (iout,*) "corr loop i",i
8467         i1=i+1
8468         num_conti=num_cont_hb(i)
8469         num_conti1=num_cont_hb(i+1)
8470         do jj=1,num_conti
8471           j=jcont_hb(jj,i)
8472           jp=iabs(j)
8473           do kk=1,num_conti1
8474             j1=jcont_hb(kk,i1)
8475             jp1=iabs(j1)
8476 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8477 !     &         ' jj=',jj,' kk=',kk
8478 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
8479             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8480                 .or. j.lt.0 .and. j1.gt.0) .and. &
8481                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8482 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8483 ! The system gains extra energy.
8484               n_corr=n_corr+1
8485               sqd1=dsqrt(d_cont(jj,i))
8486               sqd2=dsqrt(d_cont(kk,i1))
8487               sred_geom = sqd1*sqd2
8488               IF (sred_geom.lt.cutoff_corr) THEN
8489                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
8490                   ekont,fprimcont)
8491 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8492 !d     &         ' jj=',jj,' kk=',kk
8493                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8494                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8495                 do l=1,3
8496                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8497                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8498                 enddo
8499                 n_corr1=n_corr1+1
8500 !d               write (iout,*) 'sred_geom=',sred_geom,
8501 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
8502 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8503 !d               write (iout,*) "g_contij",g_contij
8504 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8505 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8506                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8507                 if (wcorr4.gt.0.0d0) &
8508                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8509                   if (energy_dec.and.wcorr4.gt.0.0d0) &
8510                        write (iout,'(a6,4i5,0pf7.3)') &
8511                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8512 !                write (iout,*) "gradcorr5 before eello5"
8513 !                do iii=1,nres
8514 !                  write (iout,'(i5,3f10.5)')
8515 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8516 !                enddo
8517                 if (wcorr5.gt.0.0d0) &
8518                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8519 !                write (iout,*) "gradcorr5 after eello5"
8520 !                do iii=1,nres
8521 !                  write (iout,'(i5,3f10.5)')
8522 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8523 !                enddo
8524                   if (energy_dec.and.wcorr5.gt.0.0d0) &
8525                        write (iout,'(a6,4i5,0pf7.3)') &
8526                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8527 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8528 !d                write(2,*)'ijkl',i,jp,i+1,jp1
8529                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
8530                      .or. wturn6.eq.0.0d0))then
8531 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8532                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8533                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8534                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8535 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8536 !d     &            'ecorr6=',ecorr6
8537 !d                write (iout,'(4e15.5)') sred_geom,
8538 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8539 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8540 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8541                 else if (wturn6.gt.0.0d0 &
8542                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8543 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8544                   eturn6=eturn6+eello_turn6(i,jj,kk)
8545                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8546                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8547 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
8548                 endif
8549               ENDIF
8550 1111          continue
8551             endif
8552           enddo ! kk
8553         enddo ! jj
8554       enddo ! i
8555       do i=1,nres
8556         num_cont_hb(i)=num_cont_hb_old(i)
8557       enddo
8558 !                write (iout,*) "gradcorr5 in eello5"
8559 !                do iii=1,nres
8560 !                  write (iout,'(i5,3f10.5)')
8561 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8562 !                enddo
8563       return
8564       end subroutine multibody_eello
8565 !-----------------------------------------------------------------------------
8566       subroutine add_hb_contact_eello(ii,jj,itask)
8567 !      implicit real*8 (a-h,o-z)
8568 !      include "DIMENSIONS"
8569 !      include "COMMON.IOUNITS"
8570 !      include "COMMON.CONTACTS"
8571 !      integer,parameter :: maxconts=nres/4
8572       integer,parameter :: max_dim=70
8573       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8574 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8575 !      common /przechowalnia/ zapas
8576
8577       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
8578       integer,dimension(4) ::itask
8579 !      write (iout,*) "itask",itask
8580       do i=1,2
8581         iproc=itask(i)
8582         if (iproc.gt.0) then
8583           do j=1,num_cont_hb(ii)
8584             jjc=jcont_hb(j,ii)
8585 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8586             if (jjc.eq.jj) then
8587               ncont_sent(iproc)=ncont_sent(iproc)+1
8588               nn=ncont_sent(iproc)
8589               zapas(1,nn,iproc)=ii
8590               zapas(2,nn,iproc)=jjc
8591               zapas(3,nn,iproc)=d_cont(j,ii)
8592               ind=3
8593               do kk=1,3
8594                 ind=ind+1
8595                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8596               enddo
8597               do kk=1,2
8598                 do ll=1,2
8599                   ind=ind+1
8600                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8601                 enddo
8602               enddo
8603               do jj=1,5
8604                 do kk=1,3
8605                   do ll=1,2
8606                     do mm=1,2
8607                       ind=ind+1
8608                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8609                     enddo
8610                   enddo
8611                 enddo
8612               enddo
8613               exit
8614             endif
8615           enddo
8616         endif
8617       enddo
8618       return
8619       end subroutine add_hb_contact_eello
8620 !-----------------------------------------------------------------------------
8621       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8622 !      implicit real*8 (a-h,o-z)
8623 !      include 'DIMENSIONS'
8624 !      include 'COMMON.IOUNITS'
8625 !      include 'COMMON.DERIV'
8626 !      include 'COMMON.INTERACT'
8627 !      include 'COMMON.CONTACTS'
8628       real(kind=8),dimension(3) :: gx,gx1
8629       logical :: lprn
8630 !el local variables
8631       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
8632       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
8633                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
8634                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
8635                    rlocshield
8636
8637       lprn=.false.
8638       eij=facont_hb(jj,i)
8639       ekl=facont_hb(kk,k)
8640       ees0pij=ees0p(jj,i)
8641       ees0pkl=ees0p(kk,k)
8642       ees0mij=ees0m(jj,i)
8643       ees0mkl=ees0m(kk,k)
8644       ekont=eij*ekl
8645       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8646 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8647 ! Following 4 lines for diagnostics.
8648 !d    ees0pkl=0.0D0
8649 !d    ees0pij=1.0D0
8650 !d    ees0mkl=0.0D0
8651 !d    ees0mij=1.0D0
8652 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8653 !     & 'Contacts ',i,j,
8654 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8655 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8656 !     & 'gradcorr_long'
8657 ! Calculate the multi-body contribution to energy.
8658 !      ecorr=ecorr+ekont*ees
8659 ! Calculate multi-body contributions to the gradient.
8660       coeffpees0pij=coeffp*ees0pij
8661       coeffmees0mij=coeffm*ees0mij
8662       coeffpees0pkl=coeffp*ees0pkl
8663       coeffmees0mkl=coeffm*ees0mkl
8664       do ll=1,3
8665 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8666         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
8667         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
8668         coeffmees0mkl*gacontm_hb1(ll,jj,i))
8669         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
8670         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
8671         coeffmees0mkl*gacontm_hb2(ll,jj,i))
8672 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8673         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
8674         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
8675         coeffmees0mij*gacontm_hb1(ll,kk,k))
8676         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
8677         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
8678         coeffmees0mij*gacontm_hb2(ll,kk,k))
8679         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
8680            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
8681            coeffmees0mkl*gacontm_hb3(ll,jj,i))
8682         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8683         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8684         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
8685            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
8686            coeffmees0mij*gacontm_hb3(ll,kk,k))
8687         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8688         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8689 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8690       enddo
8691 !      write (iout,*)
8692 !grad      do m=i+1,j-1
8693 !grad        do ll=1,3
8694 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8695 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8696 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8697 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8698 !grad        enddo
8699 !grad      enddo
8700 !grad      do m=k+1,l-1
8701 !grad        do ll=1,3
8702 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8703 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
8704 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8705 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8706 !grad        enddo
8707 !grad      enddo
8708 !      write (iout,*) "ehbcorr",ekont*ees
8709       ehbcorr=ekont*ees
8710       if (shield_mode.gt.0) then
8711        j=ees0plist(jj,i)
8712        l=ees0plist(kk,k)
8713 !C        print *,i,j,fac_shield(i),fac_shield(j),
8714 !C     &fac_shield(k),fac_shield(l)
8715         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
8716            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8717           do ilist=1,ishield_list(i)
8718            iresshield=shield_list(ilist,i)
8719            do m=1,3
8720            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8721            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8722                    rlocshield  &
8723             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8724             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8725             +rlocshield
8726            enddo
8727           enddo
8728           do ilist=1,ishield_list(j)
8729            iresshield=shield_list(ilist,j)
8730            do m=1,3
8731            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8732            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8733                    rlocshield &
8734             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8735            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8736             +rlocshield
8737            enddo
8738           enddo
8739
8740           do ilist=1,ishield_list(k)
8741            iresshield=shield_list(ilist,k)
8742            do m=1,3
8743            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8744            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8745                    rlocshield &
8746             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8747            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8748             +rlocshield
8749            enddo
8750           enddo
8751           do ilist=1,ishield_list(l)
8752            iresshield=shield_list(ilist,l)
8753            do m=1,3
8754            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8755            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8756                    rlocshield &
8757             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8758            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8759             +rlocshield
8760            enddo
8761           enddo
8762           do m=1,3
8763             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8764                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8765             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8766                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8767             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8768                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8769             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8770                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8771
8772             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8773                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8774             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8775                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8776             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8777                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8778             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8779                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8780
8781            enddo
8782       endif
8783       endif
8784       return
8785       end function ehbcorr
8786 #ifdef MOMENT
8787 !-----------------------------------------------------------------------------
8788       subroutine dipole(i,j,jj)
8789 !      implicit real*8 (a-h,o-z)
8790 !      include 'DIMENSIONS'
8791 !      include 'COMMON.IOUNITS'
8792 !      include 'COMMON.CHAIN'
8793 !      include 'COMMON.FFIELD'
8794 !      include 'COMMON.DERIV'
8795 !      include 'COMMON.INTERACT'
8796 !      include 'COMMON.CONTACTS'
8797 !      include 'COMMON.TORSION'
8798 !      include 'COMMON.VAR'
8799 !      include 'COMMON.GEO'
8800       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8801       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8802       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8803
8804       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8805       allocate(dipderx(3,5,4,maxconts,nres))
8806 !
8807
8808       iti1 = itortyp(itype(i+1,1))
8809       if (j.lt.nres-1) then
8810         itj1 = itype2loc(itype(j+1,1))
8811       else
8812         itj1=nloctyp
8813       endif
8814       do iii=1,2
8815         dipi(iii,1)=Ub2(iii,i)
8816         dipderi(iii)=Ub2der(iii,i)
8817         dipi(iii,2)=b1(iii,iti1)
8818         dipj(iii,1)=Ub2(iii,j)
8819         dipderj(iii)=Ub2der(iii,j)
8820         dipj(iii,2)=b1(iii,itj1)
8821       enddo
8822       kkk=0
8823       do iii=1,2
8824         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8825         do jjj=1,2
8826           kkk=kkk+1
8827           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8828         enddo
8829       enddo
8830       do kkk=1,5
8831         do lll=1,3
8832           mmm=0
8833           do iii=1,2
8834             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8835               auxvec(1))
8836             do jjj=1,2
8837               mmm=mmm+1
8838               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8839             enddo
8840           enddo
8841         enddo
8842       enddo
8843       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8844       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8845       do iii=1,2
8846         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8847       enddo
8848       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8849       do iii=1,2
8850         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8851       enddo
8852       return
8853       end subroutine dipole
8854 #endif
8855 !-----------------------------------------------------------------------------
8856       subroutine calc_eello(i,j,k,l,jj,kk)
8857 !
8858 ! This subroutine computes matrices and vectors needed to calculate
8859 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
8860 !
8861       use comm_kut
8862 !      implicit real*8 (a-h,o-z)
8863 !      include 'DIMENSIONS'
8864 !      include 'COMMON.IOUNITS'
8865 !      include 'COMMON.CHAIN'
8866 !      include 'COMMON.DERIV'
8867 !      include 'COMMON.INTERACT'
8868 !      include 'COMMON.CONTACTS'
8869 !      include 'COMMON.TORSION'
8870 !      include 'COMMON.VAR'
8871 !      include 'COMMON.GEO'
8872 !      include 'COMMON.FFIELD'
8873       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
8874       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
8875       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
8876               itj1
8877 !el      logical :: lprn
8878 !el      common /kutas/ lprn
8879 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8880 !d     & ' jj=',jj,' kk=',kk
8881 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8882 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8883 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8884       do iii=1,2
8885         do jjj=1,2
8886           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8887           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8888         enddo
8889       enddo
8890       call transpose2(aa1(1,1),aa1t(1,1))
8891       call transpose2(aa2(1,1),aa2t(1,1))
8892       do kkk=1,5
8893         do lll=1,3
8894           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
8895             aa1tder(1,1,lll,kkk))
8896           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
8897             aa2tder(1,1,lll,kkk))
8898         enddo
8899       enddo
8900       if (l.eq.j+1) then
8901 ! parallel orientation of the two CA-CA-CA frames.
8902         if (i.gt.1) then
8903           iti=itortyp(itype(i,1))
8904         else
8905           iti=ntortyp+1
8906         endif
8907         itk1=itortyp(itype(k+1,1))
8908         itj=itortyp(itype(j,1))
8909         if (l.lt.nres-1) then
8910           itl1=itortyp(itype(l+1,1))
8911         else
8912           itl1=ntortyp+1
8913         endif
8914 ! A1 kernel(j+1) A2T
8915 !d        do iii=1,2
8916 !d          write (iout,'(3f10.5,5x,3f10.5)')
8917 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8918 !d        enddo
8919         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8920          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
8921          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8922 ! Following matrices are needed only for 6-th order cumulants
8923         IF (wcorr6.gt.0.0d0) THEN
8924         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8925          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
8926          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8927         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8928          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
8929          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8930          ADtEAderx(1,1,1,1,1,1))
8931         lprn=.false.
8932         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8933          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
8934          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8935          ADtEA1derx(1,1,1,1,1,1))
8936         ENDIF
8937 ! End 6-th order cumulants
8938 !d        lprn=.false.
8939 !d        if (lprn) then
8940 !d        write (2,*) 'In calc_eello6'
8941 !d        do iii=1,2
8942 !d          write (2,*) 'iii=',iii
8943 !d          do kkk=1,5
8944 !d            write (2,*) 'kkk=',kkk
8945 !d            do jjj=1,2
8946 !d              write (2,'(3(2f10.5),5x)')
8947 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8948 !d            enddo
8949 !d          enddo
8950 !d        enddo
8951 !d        endif
8952         call transpose2(EUgder(1,1,k),auxmat(1,1))
8953         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8954         call transpose2(EUg(1,1,k),auxmat(1,1))
8955         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8956         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8957         do iii=1,2
8958           do kkk=1,5
8959             do lll=1,3
8960               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8961                 EAEAderx(1,1,lll,kkk,iii,1))
8962             enddo
8963           enddo
8964         enddo
8965 ! A1T kernel(i+1) A2
8966         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8967          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
8968          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8969 ! Following matrices are needed only for 6-th order cumulants
8970         IF (wcorr6.gt.0.0d0) THEN
8971         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8972          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
8973          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8974         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8975          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
8976          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8977          ADtEAderx(1,1,1,1,1,2))
8978         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8979          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
8980          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8981          ADtEA1derx(1,1,1,1,1,2))
8982         ENDIF
8983 ! End 6-th order cumulants
8984         call transpose2(EUgder(1,1,l),auxmat(1,1))
8985         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8986         call transpose2(EUg(1,1,l),auxmat(1,1))
8987         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8988         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8989         do iii=1,2
8990           do kkk=1,5
8991             do lll=1,3
8992               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8993                 EAEAderx(1,1,lll,kkk,iii,2))
8994             enddo
8995           enddo
8996         enddo
8997 ! AEAb1 and AEAb2
8998 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8999 ! They are needed only when the fifth- or the sixth-order cumulants are
9000 ! indluded.
9001         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9002         call transpose2(AEA(1,1,1),auxmat(1,1))
9003         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9004         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9005         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9006         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9007         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9008         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9009         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9010         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9011         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9012         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9013         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9014         call transpose2(AEA(1,1,2),auxmat(1,1))
9015         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
9016         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9017         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9018         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9019         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
9020         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9021         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
9022         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
9023         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9024         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9025         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9026 ! Calculate the Cartesian derivatives of the vectors.
9027         do iii=1,2
9028           do kkk=1,5
9029             do lll=1,3
9030               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9031               call matvec2(auxmat(1,1),b1(1,iti),&
9032                 AEAb1derx(1,lll,kkk,iii,1,1))
9033               call matvec2(auxmat(1,1),Ub2(1,i),&
9034                 AEAb2derx(1,lll,kkk,iii,1,1))
9035               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9036                 AEAb1derx(1,lll,kkk,iii,2,1))
9037               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9038                 AEAb2derx(1,lll,kkk,iii,2,1))
9039               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9040               call matvec2(auxmat(1,1),b1(1,itj),&
9041                 AEAb1derx(1,lll,kkk,iii,1,2))
9042               call matvec2(auxmat(1,1),Ub2(1,j),&
9043                 AEAb2derx(1,lll,kkk,iii,1,2))
9044               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9045                 AEAb1derx(1,lll,kkk,iii,2,2))
9046               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
9047                 AEAb2derx(1,lll,kkk,iii,2,2))
9048             enddo
9049           enddo
9050         enddo
9051         ENDIF
9052 ! End vectors
9053       else
9054 ! Antiparallel orientation of the two CA-CA-CA frames.
9055         if (i.gt.1) then
9056           iti=itortyp(itype(i,1))
9057         else
9058           iti=ntortyp+1
9059         endif
9060         itk1=itortyp(itype(k+1,1))
9061         itl=itortyp(itype(l,1))
9062         itj=itortyp(itype(j,1))
9063         if (j.lt.nres-1) then
9064           itj1=itortyp(itype(j+1,1))
9065         else
9066           itj1=ntortyp+1
9067         endif
9068 ! A2 kernel(j-1)T A1T
9069         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9070          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
9071          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9072 ! Following matrices are needed only for 6-th order cumulants
9073         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9074            j.eq.i+4 .and. l.eq.i+3)) THEN
9075         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9076          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
9077          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9078         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9079          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
9080          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9081          ADtEAderx(1,1,1,1,1,1))
9082         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9083          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
9084          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9085          ADtEA1derx(1,1,1,1,1,1))
9086         ENDIF
9087 ! End 6-th order cumulants
9088         call transpose2(EUgder(1,1,k),auxmat(1,1))
9089         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9090         call transpose2(EUg(1,1,k),auxmat(1,1))
9091         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9092         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9093         do iii=1,2
9094           do kkk=1,5
9095             do lll=1,3
9096               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9097                 EAEAderx(1,1,lll,kkk,iii,1))
9098             enddo
9099           enddo
9100         enddo
9101 ! A2T kernel(i+1)T A1
9102         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9103          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
9104          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9105 ! Following matrices are needed only for 6-th order cumulants
9106         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9107            j.eq.i+4 .and. l.eq.i+3)) THEN
9108         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9109          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
9110          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9111         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9112          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
9113          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9114          ADtEAderx(1,1,1,1,1,2))
9115         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9116          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
9117          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9118          ADtEA1derx(1,1,1,1,1,2))
9119         ENDIF
9120 ! End 6-th order cumulants
9121         call transpose2(EUgder(1,1,j),auxmat(1,1))
9122         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9123         call transpose2(EUg(1,1,j),auxmat(1,1))
9124         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9125         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9126         do iii=1,2
9127           do kkk=1,5
9128             do lll=1,3
9129               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9130                 EAEAderx(1,1,lll,kkk,iii,2))
9131             enddo
9132           enddo
9133         enddo
9134 ! AEAb1 and AEAb2
9135 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9136 ! They are needed only when the fifth- or the sixth-order cumulants are
9137 ! indluded.
9138         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
9139           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9140         call transpose2(AEA(1,1,1),auxmat(1,1))
9141         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9142         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9143         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9144         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9145         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9146         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9147         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9148         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9149         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9150         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9151         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9152         call transpose2(AEA(1,1,2),auxmat(1,1))
9153         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
9154         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9155         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9156         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9157         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
9158         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9159         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
9160         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
9161         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9162         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9163         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9164 ! Calculate the Cartesian derivatives of the vectors.
9165         do iii=1,2
9166           do kkk=1,5
9167             do lll=1,3
9168               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9169               call matvec2(auxmat(1,1),b1(1,iti),&
9170                 AEAb1derx(1,lll,kkk,iii,1,1))
9171               call matvec2(auxmat(1,1),Ub2(1,i),&
9172                 AEAb2derx(1,lll,kkk,iii,1,1))
9173               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9174                 AEAb1derx(1,lll,kkk,iii,2,1))
9175               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9176                 AEAb2derx(1,lll,kkk,iii,2,1))
9177               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9178               call matvec2(auxmat(1,1),b1(1,itl),&
9179                 AEAb1derx(1,lll,kkk,iii,1,2))
9180               call matvec2(auxmat(1,1),Ub2(1,l),&
9181                 AEAb2derx(1,lll,kkk,iii,1,2))
9182               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
9183                 AEAb1derx(1,lll,kkk,iii,2,2))
9184               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
9185                 AEAb2derx(1,lll,kkk,iii,2,2))
9186             enddo
9187           enddo
9188         enddo
9189         ENDIF
9190 ! End vectors
9191       endif
9192       return
9193       end subroutine calc_eello
9194 !-----------------------------------------------------------------------------
9195       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
9196       use comm_kut
9197       implicit none
9198       integer :: nderg
9199       logical :: transp
9200       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
9201       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
9202       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
9203       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
9204       integer :: iii,kkk,lll
9205       integer :: jjj,mmm
9206 !el      logical :: lprn
9207 !el      common /kutas/ lprn
9208       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9209       do iii=1,nderg
9210         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
9211           AKAderg(1,1,iii))
9212       enddo
9213 !d      if (lprn) write (2,*) 'In kernel'
9214       do kkk=1,5
9215 !d        if (lprn) write (2,*) 'kkk=',kkk
9216         do lll=1,3
9217           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
9218             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9219 !d          if (lprn) then
9220 !d            write (2,*) 'lll=',lll
9221 !d            write (2,*) 'iii=1'
9222 !d            do jjj=1,2
9223 !d              write (2,'(3(2f10.5),5x)')
9224 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9225 !d            enddo
9226 !d          endif
9227           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
9228             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9229 !d          if (lprn) then
9230 !d            write (2,*) 'lll=',lll
9231 !d            write (2,*) 'iii=2'
9232 !d            do jjj=1,2
9233 !d              write (2,'(3(2f10.5),5x)')
9234 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9235 !d            enddo
9236 !d          endif
9237         enddo
9238       enddo
9239       return
9240       end subroutine kernel
9241 !-----------------------------------------------------------------------------
9242       real(kind=8) function eello4(i,j,k,l,jj,kk)
9243 !      implicit real*8 (a-h,o-z)
9244 !      include 'DIMENSIONS'
9245 !      include 'COMMON.IOUNITS'
9246 !      include 'COMMON.CHAIN'
9247 !      include 'COMMON.DERIV'
9248 !      include 'COMMON.INTERACT'
9249 !      include 'COMMON.CONTACTS'
9250 !      include 'COMMON.TORSION'
9251 !      include 'COMMON.VAR'
9252 !      include 'COMMON.GEO'
9253       real(kind=8),dimension(2,2) :: pizda
9254       real(kind=8),dimension(3) :: ggg1,ggg2
9255       real(kind=8) ::  eel4,glongij,glongkl
9256       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9257 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9258 !d        eello4=0.0d0
9259 !d        return
9260 !d      endif
9261 !d      print *,'eello4:',i,j,k,l,jj,kk
9262 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
9263 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
9264 !old      eij=facont_hb(jj,i)
9265 !old      ekl=facont_hb(kk,k)
9266 !old      ekont=eij*ekl
9267       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9268 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9269       gcorr_loc(k-1)=gcorr_loc(k-1) &
9270          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9271       if (l.eq.j+1) then
9272         gcorr_loc(l-1)=gcorr_loc(l-1) &
9273            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9274       else
9275         gcorr_loc(j-1)=gcorr_loc(j-1) &
9276            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9277       endif
9278       do iii=1,2
9279         do kkk=1,5
9280           do lll=1,3
9281             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
9282                               -EAEAderx(2,2,lll,kkk,iii,1)
9283 !d            derx(lll,kkk,iii)=0.0d0
9284           enddo
9285         enddo
9286       enddo
9287 !d      gcorr_loc(l-1)=0.0d0
9288 !d      gcorr_loc(j-1)=0.0d0
9289 !d      gcorr_loc(k-1)=0.0d0
9290 !d      eel4=1.0d0
9291 !d      write (iout,*)'Contacts have occurred for peptide groups',
9292 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9293 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9294       if (j.lt.nres-1) then
9295         j1=j+1
9296         j2=j-1
9297       else
9298         j1=j-1
9299         j2=j-2
9300       endif
9301       if (l.lt.nres-1) then
9302         l1=l+1
9303         l2=l-1
9304       else
9305         l1=l-1
9306         l2=l-2
9307       endif
9308       do ll=1,3
9309 !grad        ggg1(ll)=eel4*g_contij(ll,1)
9310 !grad        ggg2(ll)=eel4*g_contij(ll,2)
9311         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9312         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9313 !grad        ghalf=0.5d0*ggg1(ll)
9314         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9315         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9316         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9317         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9318         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9319         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9320 !grad        ghalf=0.5d0*ggg2(ll)
9321         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9322         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9323         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9324         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9325         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9326         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9327       enddo
9328 !grad      do m=i+1,j-1
9329 !grad        do ll=1,3
9330 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9331 !grad        enddo
9332 !grad      enddo
9333 !grad      do m=k+1,l-1
9334 !grad        do ll=1,3
9335 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9336 !grad        enddo
9337 !grad      enddo
9338 !grad      do m=i+2,j2
9339 !grad        do ll=1,3
9340 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9341 !grad        enddo
9342 !grad      enddo
9343 !grad      do m=k+2,l2
9344 !grad        do ll=1,3
9345 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9346 !grad        enddo
9347 !grad      enddo
9348 !d      do iii=1,nres-3
9349 !d        write (2,*) iii,gcorr_loc(iii)
9350 !d      enddo
9351       eello4=ekont*eel4
9352 !d      write (2,*) 'ekont',ekont
9353 !d      write (iout,*) 'eello4',ekont*eel4
9354       return
9355       end function eello4
9356 !-----------------------------------------------------------------------------
9357       real(kind=8) function eello5(i,j,k,l,jj,kk)
9358 !      implicit real*8 (a-h,o-z)
9359 !      include 'DIMENSIONS'
9360 !      include 'COMMON.IOUNITS'
9361 !      include 'COMMON.CHAIN'
9362 !      include 'COMMON.DERIV'
9363 !      include 'COMMON.INTERACT'
9364 !      include 'COMMON.CONTACTS'
9365 !      include 'COMMON.TORSION'
9366 !      include 'COMMON.VAR'
9367 !      include 'COMMON.GEO'
9368       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9369       real(kind=8),dimension(2) :: vv
9370       real(kind=8),dimension(3) :: ggg1,ggg2
9371       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
9372       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
9373       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
9374 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9375 !                                                                              C
9376 !                            Parallel chains                                   C
9377 !                                                                              C
9378 !          o             o                   o             o                   C
9379 !         /l\           / \             \   / \           / \   /              C
9380 !        /   \         /   \             \ /   \         /   \ /               C
9381 !       j| o |l1       | o |                o| o |         | o |o                C
9382 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9383 !      \i/   \         /   \ /             /   \         /   \                 C
9384 !       o    k1             o                                                  C
9385 !         (I)          (II)                (III)          (IV)                 C
9386 !                                                                              C
9387 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9388 !                                                                              C
9389 !                            Antiparallel chains                               C
9390 !                                                                              C
9391 !          o             o                   o             o                   C
9392 !         /j\           / \             \   / \           / \   /              C
9393 !        /   \         /   \             \ /   \         /   \ /               C
9394 !      j1| o |l        | o |                o| o |         | o |o                C
9395 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9396 !      \i/   \         /   \ /             /   \         /   \                 C
9397 !       o     k1            o                                                  C
9398 !         (I)          (II)                (III)          (IV)                 C
9399 !                                                                              C
9400 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9401 !                                                                              C
9402 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
9403 !                                                                              C
9404 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9405 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9406 !d        eello5=0.0d0
9407 !d        return
9408 !d      endif
9409 !d      write (iout,*)
9410 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9411 !d     &   ' and',k,l
9412       itk=itortyp(itype(k,1))
9413       itl=itortyp(itype(l,1))
9414       itj=itortyp(itype(j,1))
9415       eello5_1=0.0d0
9416       eello5_2=0.0d0
9417       eello5_3=0.0d0
9418       eello5_4=0.0d0
9419 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9420 !d     &   eel5_3_num,eel5_4_num)
9421       do iii=1,2
9422         do kkk=1,5
9423           do lll=1,3
9424             derx(lll,kkk,iii)=0.0d0
9425           enddo
9426         enddo
9427       enddo
9428 !d      eij=facont_hb(jj,i)
9429 !d      ekl=facont_hb(kk,k)
9430 !d      ekont=eij*ekl
9431 !d      write (iout,*)'Contacts have occurred for peptide groups',
9432 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
9433 !d      goto 1111
9434 ! Contribution from the graph I.
9435 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9436 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9437       call transpose2(EUg(1,1,k),auxmat(1,1))
9438       call matmat2(AEA(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       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
9442        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9443 ! Explicit gradient in virtual-dihedral angles.
9444       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
9445        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
9446        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9447       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9448       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9449       vv(1)=pizda(1,1)-pizda(2,2)
9450       vv(2)=pizda(1,2)+pizda(2,1)
9451       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9452        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
9453        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9454       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9455       vv(1)=pizda(1,1)-pizda(2,2)
9456       vv(2)=pizda(1,2)+pizda(2,1)
9457       if (l.eq.j+1) then
9458         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9459          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9460          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9461       else
9462         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9463          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9464          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9465       endif
9466 ! Cartesian gradient
9467       do iii=1,2
9468         do kkk=1,5
9469           do lll=1,3
9470             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9471               pizda(1,1))
9472             vv(1)=pizda(1,1)-pizda(2,2)
9473             vv(2)=pizda(1,2)+pizda(2,1)
9474             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9475              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
9476              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9477           enddo
9478         enddo
9479       enddo
9480 !      goto 1112
9481 !1111  continue
9482 ! Contribution from graph II
9483       call transpose2(EE(1,1,itk),auxmat(1,1))
9484       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9485       vv(1)=pizda(1,1)+pizda(2,2)
9486       vv(2)=pizda(2,1)-pizda(1,2)
9487       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
9488        -0.5d0*scalar2(vv(1),Ctobr(1,k))
9489 ! Explicit gradient in virtual-dihedral angles.
9490       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9491        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9492       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9493       vv(1)=pizda(1,1)+pizda(2,2)
9494       vv(2)=pizda(2,1)-pizda(1,2)
9495       if (l.eq.j+1) then
9496         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9497          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9498          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9499       else
9500         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9501          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9502          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9503       endif
9504 ! Cartesian gradient
9505       do iii=1,2
9506         do kkk=1,5
9507           do lll=1,3
9508             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9509               pizda(1,1))
9510             vv(1)=pizda(1,1)+pizda(2,2)
9511             vv(2)=pizda(2,1)-pizda(1,2)
9512             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9513              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
9514              -0.5d0*scalar2(vv(1),Ctobr(1,k))
9515           enddo
9516         enddo
9517       enddo
9518 !d      goto 1112
9519 !d1111  continue
9520       if (l.eq.j+1) then
9521 !d        goto 1110
9522 ! Parallel orientation
9523 ! Contribution from graph III
9524         call transpose2(EUg(1,1,l),auxmat(1,1))
9525         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9526         vv(1)=pizda(1,1)-pizda(2,2)
9527         vv(2)=pizda(1,2)+pizda(2,1)
9528         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
9529          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9530 ! Explicit gradient in virtual-dihedral angles.
9531         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9532          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
9533          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9534         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9535         vv(1)=pizda(1,1)-pizda(2,2)
9536         vv(2)=pizda(1,2)+pizda(2,1)
9537         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9538          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
9539          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9540         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9541         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9542         vv(1)=pizda(1,1)-pizda(2,2)
9543         vv(2)=pizda(1,2)+pizda(2,1)
9544         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9545          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
9546          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9547 ! Cartesian gradient
9548         do iii=1,2
9549           do kkk=1,5
9550             do lll=1,3
9551               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9552                 pizda(1,1))
9553               vv(1)=pizda(1,1)-pizda(2,2)
9554               vv(2)=pizda(1,2)+pizda(2,1)
9555               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9556                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
9557                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9558             enddo
9559           enddo
9560         enddo
9561 !d        goto 1112
9562 ! Contribution from graph IV
9563 !d1110    continue
9564         call transpose2(EE(1,1,itl),auxmat(1,1))
9565         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9566         vv(1)=pizda(1,1)+pizda(2,2)
9567         vv(2)=pizda(2,1)-pizda(1,2)
9568         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
9569          -0.5d0*scalar2(vv(1),Ctobr(1,l))
9570 ! Explicit gradient in virtual-dihedral angles.
9571         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9572          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9573         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9574         vv(1)=pizda(1,1)+pizda(2,2)
9575         vv(2)=pizda(2,1)-pizda(1,2)
9576         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9577          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
9578          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9579 ! Cartesian gradient
9580         do iii=1,2
9581           do kkk=1,5
9582             do lll=1,3
9583               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9584                 pizda(1,1))
9585               vv(1)=pizda(1,1)+pizda(2,2)
9586               vv(2)=pizda(2,1)-pizda(1,2)
9587               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9588                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
9589                -0.5d0*scalar2(vv(1),Ctobr(1,l))
9590             enddo
9591           enddo
9592         enddo
9593       else
9594 ! Antiparallel orientation
9595 ! Contribution from graph III
9596 !        goto 1110
9597         call transpose2(EUg(1,1,j),auxmat(1,1))
9598         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9599         vv(1)=pizda(1,1)-pizda(2,2)
9600         vv(2)=pizda(1,2)+pizda(2,1)
9601         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
9602          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9603 ! Explicit gradient in virtual-dihedral angles.
9604         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9605          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
9606          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9607         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9608         vv(1)=pizda(1,1)-pizda(2,2)
9609         vv(2)=pizda(1,2)+pizda(2,1)
9610         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9611          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
9612          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9613         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9614         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9615         vv(1)=pizda(1,1)-pizda(2,2)
9616         vv(2)=pizda(1,2)+pizda(2,1)
9617         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9618          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
9619          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9620 ! Cartesian gradient
9621         do iii=1,2
9622           do kkk=1,5
9623             do lll=1,3
9624               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9625                 pizda(1,1))
9626               vv(1)=pizda(1,1)-pizda(2,2)
9627               vv(2)=pizda(1,2)+pizda(2,1)
9628               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9629                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
9630                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9631             enddo
9632           enddo
9633         enddo
9634 !d        goto 1112
9635 ! Contribution from graph IV
9636 1110    continue
9637         call transpose2(EE(1,1,itj),auxmat(1,1))
9638         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9639         vv(1)=pizda(1,1)+pizda(2,2)
9640         vv(2)=pizda(2,1)-pizda(1,2)
9641         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
9642          -0.5d0*scalar2(vv(1),Ctobr(1,j))
9643 ! Explicit gradient in virtual-dihedral angles.
9644         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9645          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9646         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9647         vv(1)=pizda(1,1)+pizda(2,2)
9648         vv(2)=pizda(2,1)-pizda(1,2)
9649         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9650          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
9651          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9652 ! Cartesian gradient
9653         do iii=1,2
9654           do kkk=1,5
9655             do lll=1,3
9656               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9657                 pizda(1,1))
9658               vv(1)=pizda(1,1)+pizda(2,2)
9659               vv(2)=pizda(2,1)-pizda(1,2)
9660               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9661                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
9662                -0.5d0*scalar2(vv(1),Ctobr(1,j))
9663             enddo
9664           enddo
9665         enddo
9666       endif
9667 1112  continue
9668       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9669 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9670 !d        write (2,*) 'ijkl',i,j,k,l
9671 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9672 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9673 !d      endif
9674 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9675 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9676 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9677 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9678       if (j.lt.nres-1) then
9679         j1=j+1
9680         j2=j-1
9681       else
9682         j1=j-1
9683         j2=j-2
9684       endif
9685       if (l.lt.nres-1) then
9686         l1=l+1
9687         l2=l-1
9688       else
9689         l1=l-1
9690         l2=l-2
9691       endif
9692 !d      eij=1.0d0
9693 !d      ekl=1.0d0
9694 !d      ekont=1.0d0
9695 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9696 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
9697 !        summed up outside the subrouine as for the other subroutines
9698 !        handling long-range interactions. The old code is commented out
9699 !        with "cgrad" to keep track of changes.
9700       do ll=1,3
9701 !grad        ggg1(ll)=eel5*g_contij(ll,1)
9702 !grad        ggg2(ll)=eel5*g_contij(ll,2)
9703         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9704         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9705 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9706 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9707 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9708 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9709 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9710 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9711 !     &   gradcorr5ij,
9712 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9713 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9714 !grad        ghalf=0.5d0*ggg1(ll)
9715 !d        ghalf=0.0d0
9716         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9717         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9718         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9719         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9720         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9721         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9722 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9723 !grad        ghalf=0.5d0*ggg2(ll)
9724         ghalf=0.0d0
9725         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9726         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9727         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9728         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9729         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9730         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9731       enddo
9732 !d      goto 1112
9733 !grad      do m=i+1,j-1
9734 !grad        do ll=1,3
9735 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9736 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9737 !grad        enddo
9738 !grad      enddo
9739 !grad      do m=k+1,l-1
9740 !grad        do ll=1,3
9741 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9742 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9743 !grad        enddo
9744 !grad      enddo
9745 !1112  continue
9746 !grad      do m=i+2,j2
9747 !grad        do ll=1,3
9748 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9749 !grad        enddo
9750 !grad      enddo
9751 !grad      do m=k+2,l2
9752 !grad        do ll=1,3
9753 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9754 !grad        enddo
9755 !grad      enddo
9756 !d      do iii=1,nres-3
9757 !d        write (2,*) iii,g_corr5_loc(iii)
9758 !d      enddo
9759       eello5=ekont*eel5
9760 !d      write (2,*) 'ekont',ekont
9761 !d      write (iout,*) 'eello5',ekont*eel5
9762       return
9763       end function eello5
9764 !-----------------------------------------------------------------------------
9765       real(kind=8) function eello6(i,j,k,l,jj,kk)
9766 !      implicit real*8 (a-h,o-z)
9767 !      include 'DIMENSIONS'
9768 !      include 'COMMON.IOUNITS'
9769 !      include 'COMMON.CHAIN'
9770 !      include 'COMMON.DERIV'
9771 !      include 'COMMON.INTERACT'
9772 !      include 'COMMON.CONTACTS'
9773 !      include 'COMMON.TORSION'
9774 !      include 'COMMON.VAR'
9775 !      include 'COMMON.GEO'
9776 !      include 'COMMON.FFIELD'
9777       real(kind=8),dimension(3) :: ggg1,ggg2
9778       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9779                    eello6_6,eel6
9780       real(kind=8) :: gradcorr6ij,gradcorr6kl
9781       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9782 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9783 !d        eello6=0.0d0
9784 !d        return
9785 !d      endif
9786 !d      write (iout,*)
9787 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9788 !d     &   ' and',k,l
9789       eello6_1=0.0d0
9790       eello6_2=0.0d0
9791       eello6_3=0.0d0
9792       eello6_4=0.0d0
9793       eello6_5=0.0d0
9794       eello6_6=0.0d0
9795 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9796 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9797       do iii=1,2
9798         do kkk=1,5
9799           do lll=1,3
9800             derx(lll,kkk,iii)=0.0d0
9801           enddo
9802         enddo
9803       enddo
9804 !d      eij=facont_hb(jj,i)
9805 !d      ekl=facont_hb(kk,k)
9806 !d      ekont=eij*ekl
9807 !d      eij=1.0d0
9808 !d      ekl=1.0d0
9809 !d      ekont=1.0d0
9810       if (l.eq.j+1) then
9811         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9812         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9813         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9814         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9815         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9816         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9817       else
9818         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9819         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9820         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9821         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9822         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9823           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9824         else
9825           eello6_5=0.0d0
9826         endif
9827         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9828       endif
9829 ! If turn contributions are considered, they will be handled separately.
9830       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9831 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9832 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9833 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9834 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9835 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9836 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9837 !d      goto 1112
9838       if (j.lt.nres-1) then
9839         j1=j+1
9840         j2=j-1
9841       else
9842         j1=j-1
9843         j2=j-2
9844       endif
9845       if (l.lt.nres-1) then
9846         l1=l+1
9847         l2=l-1
9848       else
9849         l1=l-1
9850         l2=l-2
9851       endif
9852       do ll=1,3
9853 !grad        ggg1(ll)=eel6*g_contij(ll,1)
9854 !grad        ggg2(ll)=eel6*g_contij(ll,2)
9855 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9856 !grad        ghalf=0.5d0*ggg1(ll)
9857 !d        ghalf=0.0d0
9858         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9859         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9860         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9861         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9862         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9863         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9864         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9865         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9866 !grad        ghalf=0.5d0*ggg2(ll)
9867 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9868 !d        ghalf=0.0d0
9869         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9870         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9871         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9872         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9873         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9874         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9875       enddo
9876 !d      goto 1112
9877 !grad      do m=i+1,j-1
9878 !grad        do ll=1,3
9879 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9880 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9881 !grad        enddo
9882 !grad      enddo
9883 !grad      do m=k+1,l-1
9884 !grad        do ll=1,3
9885 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9886 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9887 !grad        enddo
9888 !grad      enddo
9889 !grad1112  continue
9890 !grad      do m=i+2,j2
9891 !grad        do ll=1,3
9892 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9893 !grad        enddo
9894 !grad      enddo
9895 !grad      do m=k+2,l2
9896 !grad        do ll=1,3
9897 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9898 !grad        enddo
9899 !grad      enddo
9900 !d      do iii=1,nres-3
9901 !d        write (2,*) iii,g_corr6_loc(iii)
9902 !d      enddo
9903       eello6=ekont*eel6
9904 !d      write (2,*) 'ekont',ekont
9905 !d      write (iout,*) 'eello6',ekont*eel6
9906       return
9907       end function eello6
9908 !-----------------------------------------------------------------------------
9909       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
9910       use comm_kut
9911 !      implicit real*8 (a-h,o-z)
9912 !      include 'DIMENSIONS'
9913 !      include 'COMMON.IOUNITS'
9914 !      include 'COMMON.CHAIN'
9915 !      include 'COMMON.DERIV'
9916 !      include 'COMMON.INTERACT'
9917 !      include 'COMMON.CONTACTS'
9918 !      include 'COMMON.TORSION'
9919 !      include 'COMMON.VAR'
9920 !      include 'COMMON.GEO'
9921       real(kind=8),dimension(2) :: vv,vv1
9922       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
9923       logical :: swap
9924 !el      logical :: lprn
9925 !el      common /kutas/ lprn
9926       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
9927       real(kind=8) :: s1,s2,s3,s4,s5
9928 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9929 !                                                                              C
9930 !      Parallel       Antiparallel                                             C
9931 !                                                                              C
9932 !          o             o                                                     C
9933 !         /l\           /j\                                                    C
9934 !        /   \         /   \                                                   C
9935 !       /| o |         | o |\                                                  C
9936 !     \ j|/k\|  /   \  |/k\|l /                                                C
9937 !      \ /   \ /     \ /   \ /                                                 C
9938 !       o     o       o     o                                                  C
9939 !       i             i                                                        C
9940 !                                                                              C
9941 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9942       itk=itortyp(itype(k,1))
9943       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9944       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9945       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9946       call transpose2(EUgC(1,1,k),auxmat(1,1))
9947       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9948       vv1(1)=pizda1(1,1)-pizda1(2,2)
9949       vv1(2)=pizda1(1,2)+pizda1(2,1)
9950       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9951       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
9952       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
9953       s5=scalar2(vv(1),Dtobr2(1,i))
9954 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9955       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9956       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
9957        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
9958        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
9959        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
9960        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
9961        +scalar2(vv(1),Dtobr2der(1,i)))
9962       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9963       vv1(1)=pizda1(1,1)-pizda1(2,2)
9964       vv1(2)=pizda1(1,2)+pizda1(2,1)
9965       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
9966       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
9967       if (l.eq.j+1) then
9968         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
9969        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9970        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9971        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9972        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9973       else
9974         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
9975        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9976        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9977        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9978        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9979       endif
9980       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9981       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9982       vv1(1)=pizda1(1,1)-pizda1(2,2)
9983       vv1(2)=pizda1(1,2)+pizda1(2,1)
9984       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
9985        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
9986        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
9987        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9988       do iii=1,2
9989         if (swap) then
9990           ind=3-iii
9991         else
9992           ind=iii
9993         endif
9994         do kkk=1,5
9995           do lll=1,3
9996             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9997             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9998             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9999             call transpose2(EUgC(1,1,k),auxmat(1,1))
10000             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10001               pizda1(1,1))
10002             vv1(1)=pizda1(1,1)-pizda1(2,2)
10003             vv1(2)=pizda1(1,2)+pizda1(2,1)
10004             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10005             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
10006              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
10007             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
10008              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
10009             s5=scalar2(vv(1),Dtobr2(1,i))
10010             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10011           enddo
10012         enddo
10013       enddo
10014       return
10015       end function eello6_graph1
10016 !-----------------------------------------------------------------------------
10017       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
10018       use comm_kut
10019 !      implicit real*8 (a-h,o-z)
10020 !      include 'DIMENSIONS'
10021 !      include 'COMMON.IOUNITS'
10022 !      include 'COMMON.CHAIN'
10023 !      include 'COMMON.DERIV'
10024 !      include 'COMMON.INTERACT'
10025 !      include 'COMMON.CONTACTS'
10026 !      include 'COMMON.TORSION'
10027 !      include 'COMMON.VAR'
10028 !      include 'COMMON.GEO'
10029       logical :: swap
10030       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
10031       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10032 !el      logical :: lprn
10033 !el      common /kutas/ lprn
10034       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
10035       real(kind=8) :: s2,s3,s4
10036 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10037 !                                                                              C
10038 !      Parallel       Antiparallel                                             C
10039 !                                                                              C
10040 !          o             o                                                     C
10041 !     \   /l\           /j\   /                                                C
10042 !      \ /   \         /   \ /                                                 C
10043 !       o| o |         | o |o                                                  C
10044 !     \ j|/k\|      \  |/k\|l                                                  C
10045 !      \ /   \       \ /   \                                                   C
10046 !       o             o                                                        C
10047 !       i             i                                                        C
10048 !                                                                              C
10049 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10050 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10051 ! AL 7/4/01 s1 would occur in the sixth-order moment,
10052 !           but not in a cluster cumulant
10053 #ifdef MOMENT
10054       s1=dip(1,jj,i)*dip(1,kk,k)
10055 #endif
10056       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10057       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10058       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10059       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10060       call transpose2(EUg(1,1,k),auxmat(1,1))
10061       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10062       vv(1)=pizda(1,1)-pizda(2,2)
10063       vv(2)=pizda(1,2)+pizda(2,1)
10064       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10065 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10066 #ifdef MOMENT
10067       eello6_graph2=-(s1+s2+s3+s4)
10068 #else
10069       eello6_graph2=-(s2+s3+s4)
10070 #endif
10071 !      eello6_graph2=-s3
10072 ! Derivatives in gamma(i-1)
10073       if (i.gt.1) then
10074 #ifdef MOMENT
10075         s1=dipderg(1,jj,i)*dip(1,kk,k)
10076 #endif
10077         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10078         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10079         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10080         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10081 #ifdef MOMENT
10082         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10083 #else
10084         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10085 #endif
10086 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10087       endif
10088 ! Derivatives in gamma(k-1)
10089 #ifdef MOMENT
10090       s1=dip(1,jj,i)*dipderg(1,kk,k)
10091 #endif
10092       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10093       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10094       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10095       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10096       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10097       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10098       vv(1)=pizda(1,1)-pizda(2,2)
10099       vv(2)=pizda(1,2)+pizda(2,1)
10100       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10101 #ifdef MOMENT
10102       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10103 #else
10104       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10105 #endif
10106 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10107 ! Derivatives in gamma(j-1) or gamma(l-1)
10108       if (j.gt.1) then
10109 #ifdef MOMENT
10110         s1=dipderg(3,jj,i)*dip(1,kk,k)
10111 #endif
10112         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10113         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10114         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10115         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10116         vv(1)=pizda(1,1)-pizda(2,2)
10117         vv(2)=pizda(1,2)+pizda(2,1)
10118         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10119 #ifdef MOMENT
10120         if (swap) then
10121           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10122         else
10123           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10124         endif
10125 #endif
10126         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10127 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10128       endif
10129 ! Derivatives in gamma(l-1) or gamma(j-1)
10130       if (l.gt.1) then
10131 #ifdef MOMENT
10132         s1=dip(1,jj,i)*dipderg(3,kk,k)
10133 #endif
10134         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10135         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10136         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10137         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10138         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10139         vv(1)=pizda(1,1)-pizda(2,2)
10140         vv(2)=pizda(1,2)+pizda(2,1)
10141         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10142 #ifdef MOMENT
10143         if (swap) then
10144           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10145         else
10146           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10147         endif
10148 #endif
10149         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10150 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10151       endif
10152 ! Cartesian derivatives.
10153       if (lprn) then
10154         write (2,*) 'In eello6_graph2'
10155         do iii=1,2
10156           write (2,*) 'iii=',iii
10157           do kkk=1,5
10158             write (2,*) 'kkk=',kkk
10159             do jjj=1,2
10160               write (2,'(3(2f10.5),5x)') &
10161               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10162             enddo
10163           enddo
10164         enddo
10165       endif
10166       do iii=1,2
10167         do kkk=1,5
10168           do lll=1,3
10169 #ifdef MOMENT
10170             if (iii.eq.1) then
10171               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10172             else
10173               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10174             endif
10175 #endif
10176             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
10177               auxvec(1))
10178             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10179             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
10180               auxvec(1))
10181             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10182             call transpose2(EUg(1,1,k),auxmat(1,1))
10183             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
10184               pizda(1,1))
10185             vv(1)=pizda(1,1)-pizda(2,2)
10186             vv(2)=pizda(1,2)+pizda(2,1)
10187             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10188 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10189 #ifdef MOMENT
10190             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10191 #else
10192             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10193 #endif
10194             if (swap) then
10195               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10196             else
10197               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10198             endif
10199           enddo
10200         enddo
10201       enddo
10202       return
10203       end function eello6_graph2
10204 !-----------------------------------------------------------------------------
10205       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
10206 !      implicit real*8 (a-h,o-z)
10207 !      include 'DIMENSIONS'
10208 !      include 'COMMON.IOUNITS'
10209 !      include 'COMMON.CHAIN'
10210 !      include 'COMMON.DERIV'
10211 !      include 'COMMON.INTERACT'
10212 !      include 'COMMON.CONTACTS'
10213 !      include 'COMMON.TORSION'
10214 !      include 'COMMON.VAR'
10215 !      include 'COMMON.GEO'
10216       real(kind=8),dimension(2) :: vv,auxvec
10217       real(kind=8),dimension(2,2) :: pizda,auxmat
10218       logical :: swap
10219       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
10220       real(kind=8) :: s1,s2,s3,s4
10221 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10222 !                                                                              C
10223 !      Parallel       Antiparallel                                             C
10224 !                                                                              C
10225 !          o             o                                                     C
10226 !         /l\   /   \   /j\                                                    C
10227 !        /   \ /     \ /   \                                                   C
10228 !       /| o |o       o| o |\                                                  C
10229 !       j|/k\|  /      |/k\|l /                                                C
10230 !        /   \ /       /   \ /                                                 C
10231 !       /     o       /     o                                                  C
10232 !       i             i                                                        C
10233 !                                                                              C
10234 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10235 !
10236 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10237 !           energy moment and not to the cluster cumulant.
10238       iti=itortyp(itype(i,1))
10239       if (j.lt.nres-1) then
10240         itj1=itortyp(itype(j+1,1))
10241       else
10242         itj1=ntortyp+1
10243       endif
10244       itk=itortyp(itype(k,1))
10245       itk1=itortyp(itype(k+1,1))
10246       if (l.lt.nres-1) then
10247         itl1=itortyp(itype(l+1,1))
10248       else
10249         itl1=ntortyp+1
10250       endif
10251 #ifdef MOMENT
10252       s1=dip(4,jj,i)*dip(4,kk,k)
10253 #endif
10254       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
10255       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10256       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
10257       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10258       call transpose2(EE(1,1,itk),auxmat(1,1))
10259       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10260       vv(1)=pizda(1,1)+pizda(2,2)
10261       vv(2)=pizda(2,1)-pizda(1,2)
10262       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10263 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10264 !d     & "sum",-(s2+s3+s4)
10265 #ifdef MOMENT
10266       eello6_graph3=-(s1+s2+s3+s4)
10267 #else
10268       eello6_graph3=-(s2+s3+s4)
10269 #endif
10270 !      eello6_graph3=-s4
10271 ! Derivatives in gamma(k-1)
10272       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
10273       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10274       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10275       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10276 ! Derivatives in gamma(l-1)
10277       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
10278       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10279       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10280       vv(1)=pizda(1,1)+pizda(2,2)
10281       vv(2)=pizda(2,1)-pizda(1,2)
10282       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10283       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10284 ! Cartesian derivatives.
10285       do iii=1,2
10286         do kkk=1,5
10287           do lll=1,3
10288 #ifdef MOMENT
10289             if (iii.eq.1) then
10290               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10291             else
10292               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10293             endif
10294 #endif
10295             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
10296               auxvec(1))
10297             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10298             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
10299               auxvec(1))
10300             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10301             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
10302               pizda(1,1))
10303             vv(1)=pizda(1,1)+pizda(2,2)
10304             vv(2)=pizda(2,1)-pizda(1,2)
10305             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10306 #ifdef MOMENT
10307             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10308 #else
10309             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10310 #endif
10311             if (swap) then
10312               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10313             else
10314               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10315             endif
10316 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10317           enddo
10318         enddo
10319       enddo
10320       return
10321       end function eello6_graph3
10322 !-----------------------------------------------------------------------------
10323       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10324 !      implicit real*8 (a-h,o-z)
10325 !      include 'DIMENSIONS'
10326 !      include 'COMMON.IOUNITS'
10327 !      include 'COMMON.CHAIN'
10328 !      include 'COMMON.DERIV'
10329 !      include 'COMMON.INTERACT'
10330 !      include 'COMMON.CONTACTS'
10331 !      include 'COMMON.TORSION'
10332 !      include 'COMMON.VAR'
10333 !      include 'COMMON.GEO'
10334 !      include 'COMMON.FFIELD'
10335       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
10336       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10337       logical :: swap
10338       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
10339               iii,kkk,lll
10340       real(kind=8) :: s1,s2,s3,s4
10341 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10342 !                                                                              C
10343 !      Parallel       Antiparallel                                             C
10344 !                                                                              C
10345 !          o             o                                                     C
10346 !         /l\   /   \   /j\                                                    C
10347 !        /   \ /     \ /   \                                                   C
10348 !       /| o |o       o| o |\                                                  C
10349 !     \ j|/k\|      \  |/k\|l                                                  C
10350 !      \ /   \       \ /   \                                                   C
10351 !       o     \       o     \                                                  C
10352 !       i             i                                                        C
10353 !                                                                              C
10354 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10355 !
10356 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10357 !           energy moment and not to the cluster cumulant.
10358 !d      write (2,*) 'eello_graph4: wturn6',wturn6
10359       iti=itortyp(itype(i,1))
10360       itj=itortyp(itype(j,1))
10361       if (j.lt.nres-1) then
10362         itj1=itortyp(itype(j+1,1))
10363       else
10364         itj1=ntortyp+1
10365       endif
10366       itk=itortyp(itype(k,1))
10367       if (k.lt.nres-1) then
10368         itk1=itortyp(itype(k+1,1))
10369       else
10370         itk1=ntortyp+1
10371       endif
10372       itl=itortyp(itype(l,1))
10373       if (l.lt.nres-1) then
10374         itl1=itortyp(itype(l+1,1))
10375       else
10376         itl1=ntortyp+1
10377       endif
10378 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10379 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10380 !d     & ' itl',itl,' itl1',itl1
10381 #ifdef MOMENT
10382       if (imat.eq.1) then
10383         s1=dip(3,jj,i)*dip(3,kk,k)
10384       else
10385         s1=dip(2,jj,j)*dip(2,kk,l)
10386       endif
10387 #endif
10388       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10389       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10390       if (j.eq.l+1) then
10391         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
10392         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10393       else
10394         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
10395         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10396       endif
10397       call transpose2(EUg(1,1,k),auxmat(1,1))
10398       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10399       vv(1)=pizda(1,1)-pizda(2,2)
10400       vv(2)=pizda(2,1)+pizda(1,2)
10401       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10402 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10403 #ifdef MOMENT
10404       eello6_graph4=-(s1+s2+s3+s4)
10405 #else
10406       eello6_graph4=-(s2+s3+s4)
10407 #endif
10408 ! Derivatives in gamma(i-1)
10409       if (i.gt.1) then
10410 #ifdef MOMENT
10411         if (imat.eq.1) then
10412           s1=dipderg(2,jj,i)*dip(3,kk,k)
10413         else
10414           s1=dipderg(4,jj,j)*dip(2,kk,l)
10415         endif
10416 #endif
10417         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10418         if (j.eq.l+1) then
10419           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
10420           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10421         else
10422           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
10423           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10424         endif
10425         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10426         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10427 !d          write (2,*) 'turn6 derivatives'
10428 #ifdef MOMENT
10429           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10430 #else
10431           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10432 #endif
10433         else
10434 #ifdef MOMENT
10435           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10436 #else
10437           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10438 #endif
10439         endif
10440       endif
10441 ! Derivatives in gamma(k-1)
10442 #ifdef MOMENT
10443       if (imat.eq.1) then
10444         s1=dip(3,jj,i)*dipderg(2,kk,k)
10445       else
10446         s1=dip(2,jj,j)*dipderg(4,kk,l)
10447       endif
10448 #endif
10449       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10450       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10451       if (j.eq.l+1) then
10452         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
10453         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10454       else
10455         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
10456         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10457       endif
10458       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10459       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10460       vv(1)=pizda(1,1)-pizda(2,2)
10461       vv(2)=pizda(2,1)+pizda(1,2)
10462       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10463       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10464 #ifdef MOMENT
10465         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10466 #else
10467         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10468 #endif
10469       else
10470 #ifdef MOMENT
10471         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10472 #else
10473         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10474 #endif
10475       endif
10476 ! Derivatives in gamma(j-1) or gamma(l-1)
10477       if (l.eq.j+1 .and. l.gt.1) then
10478         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10479         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10480         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10481         vv(1)=pizda(1,1)-pizda(2,2)
10482         vv(2)=pizda(2,1)+pizda(1,2)
10483         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10484         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10485       else if (j.gt.1) then
10486         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10487         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10488         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10489         vv(1)=pizda(1,1)-pizda(2,2)
10490         vv(2)=pizda(2,1)+pizda(1,2)
10491         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10492         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10493           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10494         else
10495           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10496         endif
10497       endif
10498 ! Cartesian derivatives.
10499       do iii=1,2
10500         do kkk=1,5
10501           do lll=1,3
10502 #ifdef MOMENT
10503             if (iii.eq.1) then
10504               if (imat.eq.1) then
10505                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10506               else
10507                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10508               endif
10509             else
10510               if (imat.eq.1) then
10511                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10512               else
10513                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10514               endif
10515             endif
10516 #endif
10517             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
10518               auxvec(1))
10519             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10520             if (j.eq.l+1) then
10521               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10522                 b1(1,itj1),auxvec(1))
10523               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
10524             else
10525               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10526                 b1(1,itl1),auxvec(1))
10527               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
10528             endif
10529             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10530               pizda(1,1))
10531             vv(1)=pizda(1,1)-pizda(2,2)
10532             vv(2)=pizda(2,1)+pizda(1,2)
10533             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10534             if (swap) then
10535               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10536 #ifdef MOMENT
10537                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10538                    -(s1+s2+s4)
10539 #else
10540                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10541                    -(s2+s4)
10542 #endif
10543                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10544               else
10545 #ifdef MOMENT
10546                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10547 #else
10548                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10549 #endif
10550                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10551               endif
10552             else
10553 #ifdef MOMENT
10554               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10555 #else
10556               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10557 #endif
10558               if (l.eq.j+1) then
10559                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10560               else
10561                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10562               endif
10563             endif
10564           enddo
10565         enddo
10566       enddo
10567       return
10568       end function eello6_graph4
10569 !-----------------------------------------------------------------------------
10570       real(kind=8) function eello_turn6(i,jj,kk)
10571 !      implicit real*8 (a-h,o-z)
10572 !      include 'DIMENSIONS'
10573 !      include 'COMMON.IOUNITS'
10574 !      include 'COMMON.CHAIN'
10575 !      include 'COMMON.DERIV'
10576 !      include 'COMMON.INTERACT'
10577 !      include 'COMMON.CONTACTS'
10578 !      include 'COMMON.TORSION'
10579 !      include 'COMMON.VAR'
10580 !      include 'COMMON.GEO'
10581       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
10582       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
10583       real(kind=8),dimension(3) :: ggg1,ggg2
10584       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
10585       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
10586 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10587 !           the respective energy moment and not to the cluster cumulant.
10588 !el local variables
10589       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
10590       integer :: j1,j2,l1,l2,ll
10591       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
10592       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
10593       s1=0.0d0
10594       s8=0.0d0
10595       s13=0.0d0
10596 !
10597       eello_turn6=0.0d0
10598       j=i+4
10599       k=i+1
10600       l=i+3
10601       iti=itortyp(itype(i,1))
10602       itk=itortyp(itype(k,1))
10603       itk1=itortyp(itype(k+1,1))
10604       itl=itortyp(itype(l,1))
10605       itj=itortyp(itype(j,1))
10606 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10607 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
10608 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10609 !d        eello6=0.0d0
10610 !d        return
10611 !d      endif
10612 !d      write (iout,*)
10613 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10614 !d     &   ' and',k,l
10615 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
10616       do iii=1,2
10617         do kkk=1,5
10618           do lll=1,3
10619             derx_turn(lll,kkk,iii)=0.0d0
10620           enddo
10621         enddo
10622       enddo
10623 !d      eij=1.0d0
10624 !d      ekl=1.0d0
10625 !d      ekont=1.0d0
10626       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10627 !d      eello6_5=0.0d0
10628 !d      write (2,*) 'eello6_5',eello6_5
10629 #ifdef MOMENT
10630       call transpose2(AEA(1,1,1),auxmat(1,1))
10631       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10632       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
10633       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10634 #endif
10635       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10636       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10637       s2 = scalar2(b1(1,itk),vtemp1(1))
10638 #ifdef MOMENT
10639       call transpose2(AEA(1,1,2),atemp(1,1))
10640       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10641       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10642       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10643 #endif
10644       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10645       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10646       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10647 #ifdef MOMENT
10648       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10649       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10650       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10651       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10652       ss13 = scalar2(b1(1,itk),vtemp4(1))
10653       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10654 #endif
10655 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10656 !      s1=0.0d0
10657 !      s2=0.0d0
10658 !      s8=0.0d0
10659 !      s12=0.0d0
10660 !      s13=0.0d0
10661       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10662 ! Derivatives in gamma(i+2)
10663       s1d =0.0d0
10664       s8d =0.0d0
10665 #ifdef MOMENT
10666       call transpose2(AEA(1,1,1),auxmatd(1,1))
10667       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10668       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10669       call transpose2(AEAderg(1,1,2),atempd(1,1))
10670       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10671       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10672 #endif
10673       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10674       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10675       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10676 !      s1d=0.0d0
10677 !      s2d=0.0d0
10678 !      s8d=0.0d0
10679 !      s12d=0.0d0
10680 !      s13d=0.0d0
10681       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10682 ! Derivatives in gamma(i+3)
10683 #ifdef MOMENT
10684       call transpose2(AEA(1,1,1),auxmatd(1,1))
10685       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10686       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
10687       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10688 #endif
10689       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
10690       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10691       s2d = scalar2(b1(1,itk),vtemp1d(1))
10692 #ifdef MOMENT
10693       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10694       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10695 #endif
10696       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10697 #ifdef MOMENT
10698       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10699       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10700       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10701 #endif
10702 !      s1d=0.0d0
10703 !      s2d=0.0d0
10704 !      s8d=0.0d0
10705 !      s12d=0.0d0
10706 !      s13d=0.0d0
10707 #ifdef MOMENT
10708       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10709                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10710 #else
10711       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10712                     -0.5d0*ekont*(s2d+s12d)
10713 #endif
10714 ! Derivatives in gamma(i+4)
10715       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10716       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10717       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10718 #ifdef MOMENT
10719       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10720       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10721       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10722 #endif
10723 !      s1d=0.0d0
10724 !      s2d=0.0d0
10725 !      s8d=0.0d0
10726 !      s12d=0.0d0
10727 !      s13d=0.0d0
10728 #ifdef MOMENT
10729       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10730 #else
10731       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10732 #endif
10733 ! Derivatives in gamma(i+5)
10734 #ifdef MOMENT
10735       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10736       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10737       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10738 #endif
10739       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10740       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10741       s2d = scalar2(b1(1,itk),vtemp1d(1))
10742 #ifdef MOMENT
10743       call transpose2(AEA(1,1,2),atempd(1,1))
10744       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10745       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10746 #endif
10747       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10748       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10749 #ifdef MOMENT
10750       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10751       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10752       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10753 #endif
10754 !      s1d=0.0d0
10755 !      s2d=0.0d0
10756 !      s8d=0.0d0
10757 !      s12d=0.0d0
10758 !      s13d=0.0d0
10759 #ifdef MOMENT
10760       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10761                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10762 #else
10763       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10764                     -0.5d0*ekont*(s2d+s12d)
10765 #endif
10766 ! Cartesian derivatives
10767       do iii=1,2
10768         do kkk=1,5
10769           do lll=1,3
10770 #ifdef MOMENT
10771             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10772             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10773             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10774 #endif
10775             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10776             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10777                 vtemp1d(1))
10778             s2d = scalar2(b1(1,itk),vtemp1d(1))
10779 #ifdef MOMENT
10780             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10781             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10782             s8d = -(atempd(1,1)+atempd(2,2))* &
10783                  scalar2(cc(1,1,itl),vtemp2(1))
10784 #endif
10785             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10786                  auxmatd(1,1))
10787             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10788             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10789 !      s1d=0.0d0
10790 !      s2d=0.0d0
10791 !      s8d=0.0d0
10792 !      s12d=0.0d0
10793 !      s13d=0.0d0
10794 #ifdef MOMENT
10795             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10796               - 0.5d0*(s1d+s2d)
10797 #else
10798             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10799               - 0.5d0*s2d
10800 #endif
10801 #ifdef MOMENT
10802             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10803               - 0.5d0*(s8d+s12d)
10804 #else
10805             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10806               - 0.5d0*s12d
10807 #endif
10808           enddo
10809         enddo
10810       enddo
10811 #ifdef MOMENT
10812       do kkk=1,5
10813         do lll=1,3
10814           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10815             achuj_tempd(1,1))
10816           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10817           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10818           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10819           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10820           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10821             vtemp4d(1))
10822           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10823           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10824           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10825         enddo
10826       enddo
10827 #endif
10828 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10829 !d     &  16*eel_turn6_num
10830 !d      goto 1112
10831       if (j.lt.nres-1) then
10832         j1=j+1
10833         j2=j-1
10834       else
10835         j1=j-1
10836         j2=j-2
10837       endif
10838       if (l.lt.nres-1) then
10839         l1=l+1
10840         l2=l-1
10841       else
10842         l1=l-1
10843         l2=l-2
10844       endif
10845       do ll=1,3
10846 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10847 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10848 !grad        ghalf=0.5d0*ggg1(ll)
10849 !d        ghalf=0.0d0
10850         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10851         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10852         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
10853           +ekont*derx_turn(ll,2,1)
10854         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10855         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
10856           +ekont*derx_turn(ll,4,1)
10857         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10858         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10859         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10860 !grad        ghalf=0.5d0*ggg2(ll)
10861 !d        ghalf=0.0d0
10862         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
10863           +ekont*derx_turn(ll,2,2)
10864         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10865         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10866           +ekont*derx_turn(ll,4,2)
10867         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10868         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10869         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10870       enddo
10871 !d      goto 1112
10872 !grad      do m=i+1,j-1
10873 !grad        do ll=1,3
10874 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10875 !grad        enddo
10876 !grad      enddo
10877 !grad      do m=k+1,l-1
10878 !grad        do ll=1,3
10879 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10880 !grad        enddo
10881 !grad      enddo
10882 !grad1112  continue
10883 !grad      do m=i+2,j2
10884 !grad        do ll=1,3
10885 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10886 !grad        enddo
10887 !grad      enddo
10888 !grad      do m=k+2,l2
10889 !grad        do ll=1,3
10890 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10891 !grad        enddo
10892 !grad      enddo
10893 !d      do iii=1,nres-3
10894 !d        write (2,*) iii,g_corr6_loc(iii)
10895 !d      enddo
10896       eello_turn6=ekont*eel_turn6
10897 !d      write (2,*) 'ekont',ekont
10898 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
10899       return
10900       end function eello_turn6
10901 !-----------------------------------------------------------------------------
10902       subroutine MATVEC2(A1,V1,V2)
10903 !DIR$ INLINEALWAYS MATVEC2
10904 #ifndef OSF
10905 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10906 #endif
10907 !      implicit real*8 (a-h,o-z)
10908 !      include 'DIMENSIONS'
10909       real(kind=8),dimension(2) :: V1,V2
10910       real(kind=8),dimension(2,2) :: A1
10911       real(kind=8) :: vaux1,vaux2
10912 !      DO 1 I=1,2
10913 !        VI=0.0
10914 !        DO 3 K=1,2
10915 !    3     VI=VI+A1(I,K)*V1(K)
10916 !        Vaux(I)=VI
10917 !    1 CONTINUE
10918
10919       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10920       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10921
10922       v2(1)=vaux1
10923       v2(2)=vaux2
10924       end subroutine MATVEC2
10925 !-----------------------------------------------------------------------------
10926       subroutine MATMAT2(A1,A2,A3)
10927 #ifndef OSF
10928 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10929 #endif
10930 !      implicit real*8 (a-h,o-z)
10931 !      include 'DIMENSIONS'
10932       real(kind=8),dimension(2,2) :: A1,A2,A3
10933       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
10934 !      DIMENSION AI3(2,2)
10935 !        DO  J=1,2
10936 !          A3IJ=0.0
10937 !          DO K=1,2
10938 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10939 !          enddo
10940 !          A3(I,J)=A3IJ
10941 !       enddo
10942 !      enddo
10943
10944       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10945       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10946       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10947       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10948
10949       A3(1,1)=AI3_11
10950       A3(2,1)=AI3_21
10951       A3(1,2)=AI3_12
10952       A3(2,2)=AI3_22
10953       end subroutine MATMAT2
10954 !-----------------------------------------------------------------------------
10955       real(kind=8) function scalar2(u,v)
10956 !DIR$ INLINEALWAYS scalar2
10957       implicit none
10958       real(kind=8),dimension(2) :: u,v
10959       real(kind=8) :: sc
10960       integer :: i
10961       scalar2=u(1)*v(1)+u(2)*v(2)
10962       return
10963       end function scalar2
10964 !-----------------------------------------------------------------------------
10965       subroutine transpose2(a,at)
10966 !DIR$ INLINEALWAYS transpose2
10967 #ifndef OSF
10968 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
10969 #endif
10970       implicit none
10971       real(kind=8),dimension(2,2) :: a,at
10972       at(1,1)=a(1,1)
10973       at(1,2)=a(2,1)
10974       at(2,1)=a(1,2)
10975       at(2,2)=a(2,2)
10976       return
10977       end subroutine transpose2
10978 !-----------------------------------------------------------------------------
10979       subroutine transpose(n,a,at)
10980       implicit none
10981       integer :: n,i,j
10982       real(kind=8),dimension(n,n) :: a,at
10983       do i=1,n
10984         do j=1,n
10985           at(j,i)=a(i,j)
10986         enddo
10987       enddo
10988       return
10989       end subroutine transpose
10990 !-----------------------------------------------------------------------------
10991       subroutine prodmat3(a1,a2,kk,transp,prod)
10992 !DIR$ INLINEALWAYS prodmat3
10993 #ifndef OSF
10994 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
10995 #endif
10996       implicit none
10997       integer :: i,j
10998       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
10999       logical :: transp
11000 !rc      double precision auxmat(2,2),prod_(2,2)
11001
11002       if (transp) then
11003 !rc        call transpose2(kk(1,1),auxmat(1,1))
11004 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11005 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11006
11007            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
11008        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11009            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
11010        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11011            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
11012        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11013            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
11014        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11015
11016       else
11017 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11018 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11019
11020            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
11021         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11022            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
11023         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11024            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
11025         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11026            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
11027         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11028
11029       endif
11030 !      call transpose2(a2(1,1),a2t(1,1))
11031
11032 !rc      print *,transp
11033 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
11034 !rc      print *,((prod(i,j),i=1,2),j=1,2)
11035
11036       return
11037       end subroutine prodmat3
11038 !-----------------------------------------------------------------------------
11039 ! energy_p_new_barrier.F
11040 !-----------------------------------------------------------------------------
11041       subroutine sum_gradient
11042 !      implicit real*8 (a-h,o-z)
11043       use io_base, only: pdbout
11044 !      include 'DIMENSIONS'
11045 #ifndef ISNAN
11046       external proc_proc
11047 #ifdef WINPGI
11048 !MS$ATTRIBUTES C ::  proc_proc
11049 #endif
11050 #endif
11051 #ifdef MPI
11052       include 'mpif.h'
11053 #endif
11054       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
11055                    gloc_scbuf !(3,maxres)
11056
11057       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
11058 !#endif
11059 !el local variables
11060       integer :: i,j,k,ierror,ierr
11061       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
11062                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
11063                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
11064                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
11065                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
11066                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
11067                    gsccorr_max,gsccorrx_max,time00
11068
11069 !      include 'COMMON.SETUP'
11070 !      include 'COMMON.IOUNITS'
11071 !      include 'COMMON.FFIELD'
11072 !      include 'COMMON.DERIV'
11073 !      include 'COMMON.INTERACT'
11074 !      include 'COMMON.SBRIDGE'
11075 !      include 'COMMON.CHAIN'
11076 !      include 'COMMON.VAR'
11077 !      include 'COMMON.CONTROL'
11078 !      include 'COMMON.TIME1'
11079 !      include 'COMMON.MAXGRAD'
11080 !      include 'COMMON.SCCOR'
11081 #ifdef TIMING
11082       time01=MPI_Wtime()
11083 #endif
11084 !#define DEBUG
11085 #ifdef DEBUG
11086       write (iout,*) "sum_gradient gvdwc, gvdwx"
11087       do i=1,nres
11088         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11089          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
11090       enddo
11091       call flush(iout)
11092 #endif
11093 #ifdef MPI
11094         gradbufc=0.0d0
11095         gradbufx=0.0d0
11096         gradbufc_sum=0.0d0
11097         gloc_scbuf=0.0d0
11098         glocbuf=0.0d0
11099 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
11100         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
11101           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
11102 #endif
11103 !
11104 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
11105 !            in virtual-bond-vector coordinates
11106 !
11107 #ifdef DEBUG
11108 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
11109 !      do i=1,nres-1
11110 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
11111 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
11112 !      enddo
11113 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
11114 !      do i=1,nres-1
11115 !        write (iout,'(i5,3f10.5,2x,f10.5)')
11116 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
11117 !      enddo
11118 !      write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
11119 !      do i=1,nres
11120 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11121 !         i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
11122 !         (gvdwc_scpp(j,i),j=1,3)
11123 !      enddo
11124 !      write (iout,*) "gelc_long gvdwpp gel_loc_long"
11125 !      do i=1,nres
11126 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11127 !         i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
11128 !         (gelc_loc_long(j,i),j=1,3)
11129 !      enddo
11130       call flush(iout)
11131 #endif
11132 #ifdef SPLITELE
11133       do i=0,nct
11134         do j=1,3
11135           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11136                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11137                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11138                       wel_loc*gel_loc_long(j,i)+ &
11139                       wcorr*gradcorr_long(j,i)+ &
11140                       wcorr5*gradcorr5_long(j,i)+ &
11141                       wcorr6*gradcorr6_long(j,i)+ &
11142                       wturn6*gcorr6_turn_long(j,i)+ &
11143                       wstrain*ghpbc(j,i) &
11144                      +wliptran*gliptranc(j,i) &
11145                      +gradafm(j,i) &
11146                      +welec*gshieldc(j,i) &
11147                      +wcorr*gshieldc_ec(j,i) &
11148                      +wturn3*gshieldc_t3(j,i)&
11149                      +wturn4*gshieldc_t4(j,i)&
11150                      +wel_loc*gshieldc_ll(j,i)&
11151                      +wtube*gg_tube(j,i) &
11152                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11153                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11154                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11155                      wcorr_nucl*gradcorr_nucl(j,i)&
11156                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
11157                      wcatprot* gradpepcat(j,i)+ &
11158                      wcatcat*gradcatcat(j,i)+   &
11159                      wscbase*gvdwc_scbase(j,i)+ &
11160                      wpepbase*gvdwc_pepbase(j,i)+&
11161                      wscpho*gvdwc_scpho(j,i)+   &
11162                      wpeppho*gvdwc_peppho(j,i)+wcatnucl*gradnuclcat(j,i)
11163
11164
11165
11166
11167
11168         enddo
11169       enddo
11170 #else
11171       do i=0,nct
11172         do j=1,3
11173           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11174                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11175                       welec*gelc_long(j,i)+ &
11176                       wbond*gradb(j,i)+ &
11177                       wel_loc*gel_loc_long(j,i)+ &
11178                       wcorr*gradcorr_long(j,i)+ &
11179                       wcorr5*gradcorr5_long(j,i)+ &
11180                       wcorr6*gradcorr6_long(j,i)+ &
11181                       wturn6*gcorr6_turn_long(j,i)+ &
11182                       wstrain*ghpbc(j,i) &
11183                      +wliptran*gliptranc(j,i) &
11184                      +gradafm(j,i) &
11185                      +welec*gshieldc(j,i)&
11186                      +wcorr*gshieldc_ec(j,i) &
11187                      +wturn4*gshieldc_t4(j,i) &
11188                      +wel_loc*gshieldc_ll(j,i)&
11189                      +wtube*gg_tube(j,i) &
11190                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11191                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11192                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11193                      wcorr_nucl*gradcorr_nucl(j,i) &
11194                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
11195                      wcatprot* gradpepcat(j,i)+ &
11196                      wcatcat*gradcatcat(j,i)+   &
11197                      wscbase*gvdwc_scbase(j,i)+ &
11198                      wpepbase*gvdwc_pepbase(j,i)+&
11199                      wscpho*gvdwc_scpho(j,i)+&
11200                      wpeppho*gvdwc_peppho(j,i)+wcatnucl*gradnuclcat(j,i)
11201
11202
11203         enddo
11204       enddo
11205 #endif
11206 #ifdef MPI
11207       if (nfgtasks.gt.1) then
11208       time00=MPI_Wtime()
11209 #ifdef DEBUG
11210       write (iout,*) "gradbufc before allreduce"
11211       do i=1,nres
11212         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11213       enddo
11214       call flush(iout)
11215 #endif
11216       do i=0,nres
11217         do j=1,3
11218           gradbufc_sum(j,i)=gradbufc(j,i)
11219         enddo
11220       enddo
11221 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
11222 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
11223 !      time_reduce=time_reduce+MPI_Wtime()-time00
11224 #ifdef DEBUG
11225 !      write (iout,*) "gradbufc_sum after allreduce"
11226 !      do i=1,nres
11227 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
11228 !      enddo
11229 !      call flush(iout)
11230 #endif
11231 #ifdef TIMING
11232 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
11233 #endif
11234       do i=0,nres
11235         do k=1,3
11236           gradbufc(k,i)=0.0d0
11237         enddo
11238       enddo
11239 #ifdef DEBUG
11240       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
11241       write (iout,*) (i," jgrad_start",jgrad_start(i),&
11242                         " jgrad_end  ",jgrad_end(i),&
11243                         i=igrad_start,igrad_end)
11244 #endif
11245 !
11246 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
11247 ! do not parallelize this part.
11248 !
11249 !      do i=igrad_start,igrad_end
11250 !        do j=jgrad_start(i),jgrad_end(i)
11251 !          do k=1,3
11252 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
11253 !          enddo
11254 !        enddo
11255 !      enddo
11256       do j=1,3
11257         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11258       enddo
11259       do i=nres-2,-1,-1
11260         do j=1,3
11261           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11262         enddo
11263       enddo
11264 #ifdef DEBUG
11265       write (iout,*) "gradbufc after summing"
11266       do i=1,nres
11267         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11268       enddo
11269       call flush(iout)
11270 #endif
11271       else
11272 #endif
11273 !el#define DEBUG
11274 #ifdef DEBUG
11275       write (iout,*) "gradbufc"
11276       do i=1,nres
11277         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11278       enddo
11279       call flush(iout)
11280 #endif
11281 !el#undef DEBUG
11282       do i=-1,nres
11283         do j=1,3
11284           gradbufc_sum(j,i)=gradbufc(j,i)
11285           gradbufc(j,i)=0.0d0
11286         enddo
11287       enddo
11288       do j=1,3
11289         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11290       enddo
11291       do i=nres-2,-1,-1
11292         do j=1,3
11293           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11294         enddo
11295       enddo
11296 !      do i=nnt,nres-1
11297 !        do k=1,3
11298 !          gradbufc(k,i)=0.0d0
11299 !        enddo
11300 !        do j=i+1,nres
11301 !          do k=1,3
11302 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
11303 !          enddo
11304 !        enddo
11305 !      enddo
11306 !el#define DEBUG
11307 #ifdef DEBUG
11308       write (iout,*) "gradbufc after summing"
11309       do i=1,nres
11310         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11311       enddo
11312       call flush(iout)
11313 #endif
11314 !el#undef DEBUG
11315 #ifdef MPI
11316       endif
11317 #endif
11318       do k=1,3
11319         gradbufc(k,nres)=0.0d0
11320       enddo
11321 !el----------------
11322 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
11323 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
11324 !el-----------------
11325       do i=-1,nct
11326         do j=1,3
11327 #ifdef SPLITELE
11328           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11329                       wel_loc*gel_loc(j,i)+ &
11330                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11331                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11332                       wel_loc*gel_loc_long(j,i)+ &
11333                       wcorr*gradcorr_long(j,i)+ &
11334                       wcorr5*gradcorr5_long(j,i)+ &
11335                       wcorr6*gradcorr6_long(j,i)+ &
11336                       wturn6*gcorr6_turn_long(j,i))+ &
11337                       wbond*gradb(j,i)+ &
11338                       wcorr*gradcorr(j,i)+ &
11339                       wturn3*gcorr3_turn(j,i)+ &
11340                       wturn4*gcorr4_turn(j,i)+ &
11341                       wcorr5*gradcorr5(j,i)+ &
11342                       wcorr6*gradcorr6(j,i)+ &
11343                       wturn6*gcorr6_turn(j,i)+ &
11344                       wsccor*gsccorc(j,i) &
11345                      +wscloc*gscloc(j,i)  &
11346                      +wliptran*gliptranc(j,i) &
11347                      +gradafm(j,i) &
11348                      +welec*gshieldc(j,i) &
11349                      +welec*gshieldc_loc(j,i) &
11350                      +wcorr*gshieldc_ec(j,i) &
11351                      +wcorr*gshieldc_loc_ec(j,i) &
11352                      +wturn3*gshieldc_t3(j,i) &
11353                      +wturn3*gshieldc_loc_t3(j,i) &
11354                      +wturn4*gshieldc_t4(j,i) &
11355                      +wturn4*gshieldc_loc_t4(j,i) &
11356                      +wel_loc*gshieldc_ll(j,i) &
11357                      +wel_loc*gshieldc_loc_ll(j,i) &
11358                      +wtube*gg_tube(j,i) &
11359                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11360                      +wvdwpsb*gvdwpsb1(j,i))&
11361                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
11362 !                      if (i.eq.21) then
11363 !                      print *,"in sum",gradc(j,i,icg),wturn4*gcorr4_turn(j,i),&
11364 !                      wturn4*gshieldc_t4(j,i), &
11365 !                     wturn4*gshieldc_loc_t4(j,i)
11366 !                       endif
11367 !                 if ((i.le.2).and.(i.ge.1))
11368 !                       print *,gradc(j,i,icg),&
11369 !                      gradbufc(j,i),welec*gelc(j,i), &
11370 !                      wel_loc*gel_loc(j,i), &
11371 !                      wscp*gvdwc_scpp(j,i), &
11372 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
11373 !                      wel_loc*gel_loc_long(j,i), &
11374 !                      wcorr*gradcorr_long(j,i), &
11375 !                      wcorr5*gradcorr5_long(j,i), &
11376 !                      wcorr6*gradcorr6_long(j,i), &
11377 !                      wturn6*gcorr6_turn_long(j,i), &
11378 !                      wbond*gradb(j,i), &
11379 !                      wcorr*gradcorr(j,i), &
11380 !                      wturn3*gcorr3_turn(j,i), &
11381 !                      wturn4*gcorr4_turn(j,i), &
11382 !                      wcorr5*gradcorr5(j,i), &
11383 !                      wcorr6*gradcorr6(j,i), &
11384 !                      wturn6*gcorr6_turn(j,i), &
11385 !                      wsccor*gsccorc(j,i) &
11386 !                     ,wscloc*gscloc(j,i)  &
11387 !                     ,wliptran*gliptranc(j,i) &
11388 !                    ,gradafm(j,i) &
11389 !                     ,welec*gshieldc(j,i) &
11390 !                     ,welec*gshieldc_loc(j,i) &
11391 !                     ,wcorr*gshieldc_ec(j,i) &
11392 !                     ,wcorr*gshieldc_loc_ec(j,i) &
11393 !                     ,wturn3*gshieldc_t3(j,i) &
11394 !                     ,wturn3*gshieldc_loc_t3(j,i) &
11395 !                     ,wturn4*gshieldc_t4(j,i) &
11396 !                     ,wturn4*gshieldc_loc_t4(j,i) &
11397 !                     ,wel_loc*gshieldc_ll(j,i) &
11398 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
11399 !                     ,wtube*gg_tube(j,i) &
11400 !                     ,wbond_nucl*gradb_nucl(j,i) &
11401 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
11402 !                     wvdwpsb*gvdwpsb1(j,i)&
11403 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
11404 !
11405
11406 #else
11407           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11408                       wel_loc*gel_loc(j,i)+ &
11409                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11410                       welec*gelc_long(j,i)+ &
11411                       wel_loc*gel_loc_long(j,i)+ &
11412 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
11413                       wcorr5*gradcorr5_long(j,i)+ &
11414                       wcorr6*gradcorr6_long(j,i)+ &
11415                       wturn6*gcorr6_turn_long(j,i))+ &
11416                       wbond*gradb(j,i)+ &
11417                       wcorr*gradcorr(j,i)+ &
11418                       wturn3*gcorr3_turn(j,i)+ &
11419                       wturn4*gcorr4_turn(j,i)+ &
11420                       wcorr5*gradcorr5(j,i)+ &
11421                       wcorr6*gradcorr6(j,i)+ &
11422                       wturn6*gcorr6_turn(j,i)+ &
11423                       wsccor*gsccorc(j,i) &
11424                      +wscloc*gscloc(j,i) &
11425                      +gradafm(j,i) &
11426                      +wliptran*gliptranc(j,i) &
11427                      +welec*gshieldc(j,i) &
11428                      +welec*gshieldc_loc(j,i) &
11429                      +wcorr*gshieldc_ec(j,i) &
11430                      +wcorr*gshieldc_loc_ec(j,i) &
11431                      +wturn3*gshieldc_t3(j,i) &
11432                      +wturn3*gshieldc_loc_t3(j,i) &
11433                      +wturn4*gshieldc_t4(j,i) &
11434                      +wturn4*gshieldc_loc_t4(j,i) &
11435                      +wel_loc*gshieldc_ll(j,i) &
11436                      +wel_loc*gshieldc_loc_ll(j,i) &
11437                      +wtube*gg_tube(j,i) &
11438                      +wbond_nucl*gradb_nucl(j,i) &
11439                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11440                      +wvdwpsb*gvdwpsb1(j,i))&
11441                      +wsbloc*gsbloc(j,i)+wcatnucl*gradnuclcat(j,i)
11442
11443
11444
11445
11446 #endif
11447           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
11448                         wbond*gradbx(j,i)+ &
11449                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
11450                         wsccor*gsccorx(j,i) &
11451                        +wscloc*gsclocx(j,i) &
11452                        +wliptran*gliptranx(j,i) &
11453                        +welec*gshieldx(j,i)     &
11454                        +wcorr*gshieldx_ec(j,i)  &
11455                        +wturn3*gshieldx_t3(j,i) &
11456                        +wturn4*gshieldx_t4(j,i) &
11457                        +wel_loc*gshieldx_ll(j,i)&
11458                        +wtube*gg_tube_sc(j,i)   &
11459                        +wbond_nucl*gradbx_nucl(j,i) &
11460                        +wvdwsb*gvdwsbx(j,i) &
11461                        +welsb*gelsbx(j,i) &
11462                        +wcorr_nucl*gradxorr_nucl(j,i)&
11463                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
11464                        +wsbloc*gsblocx(j,i) &
11465                        +wcatprot* gradpepcatx(j,i)&
11466                        +wscbase*gvdwx_scbase(j,i) &
11467                        +wpepbase*gvdwx_pepbase(j,i)&
11468                        +wscpho*gvdwx_scpho(j,i)+wcatnucl*gradnuclcatx(j,i)
11469 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
11470
11471         enddo
11472       enddo
11473 !#define DEBUG
11474 #ifdef DEBUG
11475       write (iout,*) "gloc before adding corr"
11476       do i=1,4*nres
11477         write (iout,*) i,gloc(i,icg)
11478       enddo
11479 #endif
11480       do i=1,nres-3
11481         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
11482          +wcorr5*g_corr5_loc(i) &
11483          +wcorr6*g_corr6_loc(i) &
11484          +wturn4*gel_loc_turn4(i) &
11485          +wturn3*gel_loc_turn3(i) &
11486          +wturn6*gel_loc_turn6(i) &
11487          +wel_loc*gel_loc_loc(i)
11488       enddo
11489 #ifdef DEBUG
11490       write (iout,*) "gloc after adding corr"
11491       do i=1,4*nres
11492         write (iout,*) i,gloc(i,icg)
11493       enddo
11494 #endif
11495 !#undef DEBUG
11496 #ifdef MPI
11497       if (nfgtasks.gt.1) then
11498         do j=1,3
11499           do i=0,nres
11500             gradbufc(j,i)=gradc(j,i,icg)
11501             gradbufx(j,i)=gradx(j,i,icg)
11502           enddo
11503         enddo
11504         do i=1,4*nres
11505           glocbuf(i)=gloc(i,icg)
11506         enddo
11507 !#define DEBUG
11508 #ifdef DEBUG
11509       write (iout,*) "gloc_sc before reduce"
11510       do i=1,nres
11511        do j=1,1
11512         write (iout,*) i,j,gloc_sc(j,i,icg)
11513        enddo
11514       enddo
11515 #endif
11516 !#undef DEBUG
11517         do i=0,nres
11518          do j=1,3
11519           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
11520          enddo
11521         enddo
11522         time00=MPI_Wtime()
11523         call MPI_Barrier(FG_COMM,IERR)
11524         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
11525         time00=MPI_Wtime()
11526         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
11527           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11528         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
11529           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11530         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
11531           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11532         time_reduce=time_reduce+MPI_Wtime()-time00
11533         call MPI_Reduce(gloc_scbuf(1,0),gloc_sc(1,0,icg),3*nres+3,&
11534           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11535         time_reduce=time_reduce+MPI_Wtime()-time00
11536 !#define DEBUG
11537 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
11538 #ifdef DEBUG
11539       write (iout,*) "gloc_sc after reduce"
11540       do i=0,nres
11541        do j=1,1
11542         write (iout,*) i,j,gloc_sc(j,i,icg)
11543        enddo
11544       enddo
11545 #endif
11546 !#undef DEBUG
11547 #ifdef DEBUG
11548       write (iout,*) "gloc after reduce"
11549       do i=1,4*nres
11550         write (iout,*) i,gloc(i,icg)
11551       enddo
11552 #endif
11553       endif
11554 #endif
11555       if (gnorm_check) then
11556 !
11557 ! Compute the maximum elements of the gradient
11558 !
11559       gvdwc_max=0.0d0
11560       gvdwc_scp_max=0.0d0
11561       gelc_max=0.0d0
11562       gvdwpp_max=0.0d0
11563       gradb_max=0.0d0
11564       ghpbc_max=0.0d0
11565       gradcorr_max=0.0d0
11566       gel_loc_max=0.0d0
11567       gcorr3_turn_max=0.0d0
11568       gcorr4_turn_max=0.0d0
11569       gradcorr5_max=0.0d0
11570       gradcorr6_max=0.0d0
11571       gcorr6_turn_max=0.0d0
11572       gsccorc_max=0.0d0
11573       gscloc_max=0.0d0
11574       gvdwx_max=0.0d0
11575       gradx_scp_max=0.0d0
11576       ghpbx_max=0.0d0
11577       gradxorr_max=0.0d0
11578       gsccorx_max=0.0d0
11579       gsclocx_max=0.0d0
11580       do i=1,nct
11581         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
11582         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
11583         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
11584         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
11585          gvdwc_scp_max=gvdwc_scp_norm
11586         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
11587         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
11588         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
11589         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
11590         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
11591         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
11592         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
11593         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
11594         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
11595         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
11596         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
11597         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
11598         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
11599           gcorr3_turn(1,i)))
11600         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
11601           gcorr3_turn_max=gcorr3_turn_norm
11602         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
11603           gcorr4_turn(1,i)))
11604         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
11605           gcorr4_turn_max=gcorr4_turn_norm
11606         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
11607         if (gradcorr5_norm.gt.gradcorr5_max) &
11608           gradcorr5_max=gradcorr5_norm
11609         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
11610         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
11611         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
11612           gcorr6_turn(1,i)))
11613         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
11614           gcorr6_turn_max=gcorr6_turn_norm
11615         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
11616         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
11617         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
11618         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
11619         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
11620         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
11621         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
11622         if (gradx_scp_norm.gt.gradx_scp_max) &
11623           gradx_scp_max=gradx_scp_norm
11624         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
11625         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
11626         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
11627         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
11628         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
11629         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
11630         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
11631         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
11632       enddo
11633       if (gradout) then
11634 #ifdef AIX
11635         open(istat,file=statname,position="append")
11636 #else
11637         open(istat,file=statname,access="append")
11638 #endif
11639         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
11640            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
11641            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
11642            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
11643            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
11644            gsccorx_max,gsclocx_max
11645         close(istat)
11646         if (gvdwc_max.gt.1.0d4) then
11647           write (iout,*) "gvdwc gvdwx gradb gradbx"
11648           do i=nnt,nct
11649             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
11650               gradb(j,i),gradbx(j,i),j=1,3)
11651           enddo
11652           call pdbout(0.0d0,'cipiszcze',iout)
11653           call flush(iout)
11654         endif
11655       endif
11656       endif
11657 !#define DEBUG
11658 #ifdef DEBUG
11659       write (iout,*) "gradc gradx gloc"
11660       do i=1,nres
11661         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
11662          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
11663       enddo
11664 #endif
11665 !#undef DEBUG
11666 #ifdef TIMING
11667       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
11668 #endif
11669       return
11670       end subroutine sum_gradient
11671 !-----------------------------------------------------------------------------
11672       subroutine sc_grad
11673 !      implicit real*8 (a-h,o-z)
11674       use calc_data
11675 !      include 'DIMENSIONS'
11676 !      include 'COMMON.CHAIN'
11677 !      include 'COMMON.DERIV'
11678 !      include 'COMMON.CALC'
11679 !      include 'COMMON.IOUNITS'
11680       real(kind=8), dimension(3) :: dcosom1,dcosom2
11681 !      print *,"wchodze"
11682       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11683           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11684       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11685           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11686
11687       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11688            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11689            +dCAVdOM12+ dGCLdOM12
11690 ! diagnostics only
11691 !      eom1=0.0d0
11692 !      eom2=0.0d0
11693 !      eom12=evdwij*eps1_om12
11694 ! end diagnostics
11695 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
11696 !       " sigder",sigder
11697 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
11698 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
11699 !C      print *,sss_ele_cut,'in sc_grad'
11700       do k=1,3
11701         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11702         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
11703       enddo
11704       do k=1,3
11705         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
11706 !C      print *,'gg',k,gg(k)
11707        enddo
11708 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11709 !      write (iout,*) "gg",(gg(k),k=1,3)
11710       do k=1,3
11711         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
11712                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11713                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
11714                   *sss_ele_cut
11715
11716         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
11717                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11718                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
11719                   *sss_ele_cut
11720
11721 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11722 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11723 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11724 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11725       enddo
11726 !
11727 ! Calculate the components of the gradient in DC and X
11728 !
11729 !grad      do k=i,j-1
11730 !grad        do l=1,3
11731 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
11732 !grad        enddo
11733 !grad      enddo
11734       do l=1,3
11735         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
11736         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
11737       enddo
11738       return
11739       end subroutine sc_grad
11740
11741       subroutine sc_grad_cat
11742       use calc_data
11743       real(kind=8), dimension(3) :: dcosom1,dcosom2
11744       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11745           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11746       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11747           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11748
11749       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11750            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11751            +dCAVdOM12+ dGCLdOM12
11752 ! diagnostics only
11753 !      eom1=0.0d0
11754 !      eom2=0.0d0
11755 !      eom12=evdwij*eps1_om12
11756 ! end diagnostics
11757
11758       do k=1,3
11759         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11760         dcosom2(k)=rij*(dc_norm(k,j)-om2*erij(k))
11761       enddo
11762       do k=1,3
11763         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))
11764 !C      print *,'gg',k,gg(k)
11765        enddo
11766 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11767 !      write (iout,*) "gg",(gg(k),k=1,3)
11768       do k=1,3
11769         gradpepcatx(k,i)=gradpepcatx(k,i)-gg(k) &
11770                   +(eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
11771                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11772
11773 !        gradpepcatx(k,j)=gradpepcatx(k,j)+gg(k) &
11774 !                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)) &
11775 !                  +eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv
11776
11777 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11778 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11779 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11780 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11781       enddo
11782 !
11783 ! Calculate the components of the gradient in DC and X
11784 !
11785       do l=1,3
11786         gradpepcat(l,i)=gradpepcat(l,i)-gg(l)
11787         gradpepcat(l,j)=gradpepcat(l,j)+gg(l)
11788       enddo
11789       end subroutine sc_grad_cat
11790
11791       subroutine sc_grad_cat_pep
11792       use calc_data
11793       real(kind=8), dimension(3) :: dcosom1,dcosom2
11794       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11795           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11796       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11797           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11798
11799       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11800            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11801            +dCAVdOM12+ dGCLdOM12
11802 ! diagnostics only
11803 !      eom1=0.0d0
11804 !      eom2=0.0d0
11805 !      eom12=evdwij*eps1_om12
11806 ! end diagnostics
11807
11808       do k=1,3
11809         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
11810         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
11811         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
11812         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
11813                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
11814                  *dsci_inv*2.0 &
11815                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
11816         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
11817                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
11818                  *dsci_inv*2.0 &
11819                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
11820         gradpepcat(k,j)=gradpepcat(k,j)+gg(k)
11821       enddo
11822       end subroutine sc_grad_cat_pep
11823
11824 #ifdef CRYST_THETA
11825 !-----------------------------------------------------------------------------
11826       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
11827
11828       use comm_calcthet
11829 !      implicit real*8 (a-h,o-z)
11830 !      include 'DIMENSIONS'
11831 !      include 'COMMON.LOCAL'
11832 !      include 'COMMON.IOUNITS'
11833 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
11834 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11835 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
11836       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
11837       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
11838 !el      integer :: it
11839 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
11840 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11841 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
11842 !el local variables
11843
11844       delthec=thetai-thet_pred_mean
11845       delthe0=thetai-theta0i
11846 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
11847       t3 = thetai-thet_pred_mean
11848       t6 = t3**2
11849       t9 = term1
11850       t12 = t3*sigcsq
11851       t14 = t12+t6*sigsqtc
11852       t16 = 1.0d0
11853       t21 = thetai-theta0i
11854       t23 = t21**2
11855       t26 = term2
11856       t27 = t21*t26
11857       t32 = termexp
11858       t40 = t32**2
11859       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
11860        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
11861        *(-t12*t9-ak*sig0inv*t27)
11862       return
11863       end subroutine mixder
11864 #endif
11865 !-----------------------------------------------------------------------------
11866 ! cartder.F
11867 !-----------------------------------------------------------------------------
11868       subroutine cartder
11869 !-----------------------------------------------------------------------------
11870 ! This subroutine calculates the derivatives of the consecutive virtual
11871 ! bond vectors and the SC vectors in the virtual-bond angles theta and
11872 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
11873 ! in the angles alpha and omega, describing the location of a side chain
11874 ! in its local coordinate system.
11875 !
11876 ! The derivatives are stored in the following arrays:
11877 !
11878 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
11879 ! The structure is as follows:
11880 !
11881 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
11882 ! 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)
11883 !         . . . . . . . . . . . .  . . . . . .
11884 ! 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)
11885 !                          .
11886 !                          .
11887 !                          .
11888 ! 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)
11889 !
11890 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
11891 ! The structure is same as above.
11892 !
11893 ! DCDS - the derivatives of the side chain vectors in the local spherical
11894 ! andgles alph and omega:
11895 !
11896 ! 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)
11897 ! 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)
11898 !                          .
11899 !                          .
11900 !                          .
11901 ! 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)
11902 !
11903 ! Version of March '95, based on an early version of November '91.
11904 !
11905 !**********************************************************************
11906 !      implicit real*8 (a-h,o-z)
11907 !      include 'DIMENSIONS'
11908 !      include 'COMMON.VAR'
11909 !      include 'COMMON.CHAIN'
11910 !      include 'COMMON.DERIV'
11911 !      include 'COMMON.GEO'
11912 !      include 'COMMON.LOCAL'
11913 !      include 'COMMON.INTERACT'
11914       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
11915       real(kind=8),dimension(3,3) :: dp,temp
11916 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
11917       real(kind=8),dimension(3) :: xx,xx1
11918 !el local variables
11919       integer :: i,k,l,j,m,ind,ind1,jjj
11920       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
11921                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
11922                  sint2,xp,yp,xxp,yyp,zzp,dj
11923
11924 !      common /przechowalnia/ fromto
11925       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
11926 ! get the position of the jth ijth fragment of the chain coordinate system
11927 ! in the fromto array.
11928 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11929 !
11930 !      maxdim=(nres-1)*(nres-2)/2
11931 !      allocate(dcdv(6,maxdim),dxds(6,nres))
11932 ! calculate the derivatives of transformation matrix elements in theta
11933 !
11934
11935 !el      call flush(iout) !el
11936       do i=1,nres-2
11937         rdt(1,1,i)=-rt(1,2,i)
11938         rdt(1,2,i)= rt(1,1,i)
11939         rdt(1,3,i)= 0.0d0
11940         rdt(2,1,i)=-rt(2,2,i)
11941         rdt(2,2,i)= rt(2,1,i)
11942         rdt(2,3,i)= 0.0d0
11943         rdt(3,1,i)=-rt(3,2,i)
11944         rdt(3,2,i)= rt(3,1,i)
11945         rdt(3,3,i)= 0.0d0
11946       enddo
11947 !
11948 ! derivatives in phi
11949 !
11950       do i=2,nres-2
11951         drt(1,1,i)= 0.0d0
11952         drt(1,2,i)= 0.0d0
11953         drt(1,3,i)= 0.0d0
11954         drt(2,1,i)= rt(3,1,i)
11955         drt(2,2,i)= rt(3,2,i)
11956         drt(2,3,i)= rt(3,3,i)
11957         drt(3,1,i)=-rt(2,1,i)
11958         drt(3,2,i)=-rt(2,2,i)
11959         drt(3,3,i)=-rt(2,3,i)
11960       enddo
11961 !
11962 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
11963 !
11964       do i=2,nres-2
11965         ind=indmat(i,i+1)
11966         do k=1,3
11967           do l=1,3
11968             temp(k,l)=rt(k,l,i)
11969           enddo
11970         enddo
11971         do k=1,3
11972           do l=1,3
11973             fromto(k,l,ind)=temp(k,l)
11974           enddo
11975         enddo
11976         do j=i+1,nres-2
11977           ind=indmat(i,j+1)
11978           do k=1,3
11979             do l=1,3
11980               dpkl=0.0d0
11981               do m=1,3
11982                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
11983               enddo
11984               dp(k,l)=dpkl
11985               fromto(k,l,ind)=dpkl
11986             enddo
11987           enddo
11988           do k=1,3
11989             do l=1,3
11990               temp(k,l)=dp(k,l)
11991             enddo
11992           enddo
11993         enddo
11994       enddo
11995 !
11996 ! Calculate derivatives.
11997 !
11998       ind1=0
11999       do i=1,nres-2
12000       ind1=ind1+1
12001 !
12002 ! Derivatives of DC(i+1) in theta(i+2)
12003 !
12004         do j=1,3
12005           do k=1,2
12006             dpjk=0.0D0
12007             do l=1,3
12008               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
12009             enddo
12010             dp(j,k)=dpjk
12011             prordt(j,k,i)=dp(j,k)
12012           enddo
12013           dp(j,3)=0.0D0
12014           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
12015         enddo
12016 !
12017 ! Derivatives of SC(i+1) in theta(i+2)
12018 !
12019         xx1(1)=-0.5D0*xloc(2,i+1)
12020         xx1(2)= 0.5D0*xloc(1,i+1)
12021         do j=1,3
12022           xj=0.0D0
12023           do k=1,2
12024             xj=xj+r(j,k,i)*xx1(k)
12025           enddo
12026           xx(j)=xj
12027         enddo
12028         do j=1,3
12029           rj=0.0D0
12030           do k=1,3
12031             rj=rj+prod(j,k,i)*xx(k)
12032           enddo
12033           dxdv(j,ind1)=rj
12034         enddo
12035 !
12036 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
12037 ! than the other off-diagonal derivatives.
12038 !
12039         do j=1,3
12040           dxoiij=0.0D0
12041           do k=1,3
12042             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12043           enddo
12044           dxdv(j,ind1+1)=dxoiij
12045         enddo
12046 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
12047 !
12048 ! Derivatives of DC(i+1) in phi(i+2)
12049 !
12050         do j=1,3
12051           do k=1,3
12052             dpjk=0.0
12053             do l=2,3
12054               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
12055             enddo
12056             dp(j,k)=dpjk
12057             prodrt(j,k,i)=dp(j,k)
12058           enddo
12059           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
12060         enddo
12061 !
12062 ! Derivatives of SC(i+1) in phi(i+2)
12063 !
12064         xx(1)= 0.0D0
12065         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
12066         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
12067         do j=1,3
12068           rj=0.0D0
12069           do k=2,3
12070             rj=rj+prod(j,k,i)*xx(k)
12071           enddo
12072           dxdv(j+3,ind1)=-rj
12073         enddo
12074 !
12075 ! Derivatives of SC(i+1) in phi(i+3).
12076 !
12077         do j=1,3
12078           dxoiij=0.0D0
12079           do k=1,3
12080             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12081           enddo
12082           dxdv(j+3,ind1+1)=dxoiij
12083         enddo
12084 !
12085 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
12086 ! theta(nres) and phi(i+3) thru phi(nres).
12087 !
12088         do j=i+1,nres-2
12089         ind1=ind1+1
12090         ind=indmat(i+1,j+1)
12091 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
12092           do k=1,3
12093             do l=1,3
12094               tempkl=0.0D0
12095               do m=1,2
12096                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
12097               enddo
12098               temp(k,l)=tempkl
12099             enddo
12100           enddo
12101 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
12102 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
12103 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
12104 ! Derivatives of virtual-bond vectors in theta
12105           do k=1,3
12106             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
12107           enddo
12108 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
12109 ! Derivatives of SC vectors in theta
12110           do k=1,3
12111             dxoijk=0.0D0
12112             do l=1,3
12113               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12114             enddo
12115             dxdv(k,ind1+1)=dxoijk
12116           enddo
12117 !
12118 !--- Calculate the derivatives in phi
12119 !
12120           do k=1,3
12121             do l=1,3
12122               tempkl=0.0D0
12123               do m=1,3
12124                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
12125               enddo
12126               temp(k,l)=tempkl
12127             enddo
12128           enddo
12129           do k=1,3
12130             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
12131         enddo
12132           do k=1,3
12133             dxoijk=0.0D0
12134             do l=1,3
12135               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12136             enddo
12137             dxdv(k+3,ind1+1)=dxoijk
12138           enddo
12139         enddo
12140       enddo
12141 !
12142 ! Derivatives in alpha and omega:
12143 !
12144       do i=2,nres-1
12145 !       dsci=dsc(itype(i,1))
12146         dsci=vbld(i+nres)
12147 #ifdef OSF
12148         alphi=alph(i)
12149         omegi=omeg(i)
12150         if(alphi.ne.alphi) alphi=100.0
12151         if(omegi.ne.omegi) omegi=-100.0
12152 #else
12153       alphi=alph(i)
12154       omegi=omeg(i)
12155 #endif
12156 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
12157       cosalphi=dcos(alphi)
12158       sinalphi=dsin(alphi)
12159       cosomegi=dcos(omegi)
12160       sinomegi=dsin(omegi)
12161       temp(1,1)=-dsci*sinalphi
12162       temp(2,1)= dsci*cosalphi*cosomegi
12163       temp(3,1)=-dsci*cosalphi*sinomegi
12164       temp(1,2)=0.0D0
12165       temp(2,2)=-dsci*sinalphi*sinomegi
12166       temp(3,2)=-dsci*sinalphi*cosomegi
12167       theta2=pi-0.5D0*theta(i+1)
12168       cost2=dcos(theta2)
12169       sint2=dsin(theta2)
12170       jjj=0
12171 !d      print *,((temp(l,k),l=1,3),k=1,2)
12172         do j=1,2
12173         xp=temp(1,j)
12174         yp=temp(2,j)
12175         xxp= xp*cost2+yp*sint2
12176         yyp=-xp*sint2+yp*cost2
12177         zzp=temp(3,j)
12178         xx(1)=xxp
12179         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
12180         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
12181         do k=1,3
12182           dj=0.0D0
12183           do l=1,3
12184             dj=dj+prod(k,l,i-1)*xx(l)
12185             enddo
12186           dxds(jjj+k,i)=dj
12187           enddo
12188         jjj=jjj+3
12189       enddo
12190       enddo
12191       return
12192       end subroutine cartder
12193 !-----------------------------------------------------------------------------
12194 ! checkder_p.F
12195 !-----------------------------------------------------------------------------
12196       subroutine check_cartgrad
12197 ! Check the gradient of Cartesian coordinates in internal coordinates.
12198 !      implicit real*8 (a-h,o-z)
12199 !      include 'DIMENSIONS'
12200 !      include 'COMMON.IOUNITS'
12201 !      include 'COMMON.VAR'
12202 !      include 'COMMON.CHAIN'
12203 !      include 'COMMON.GEO'
12204 !      include 'COMMON.LOCAL'
12205 !      include 'COMMON.DERIV'
12206       real(kind=8),dimension(6,nres) :: temp
12207       real(kind=8),dimension(3) :: xx,gg
12208       integer :: i,k,j,ii
12209       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
12210 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12211 !
12212 ! Check the gradient of the virtual-bond and SC vectors in the internal
12213 ! coordinates.
12214 !
12215       aincr=1.0d-6
12216       aincr2=5.0d-7
12217       call cartder
12218       write (iout,'(a)') '**************** dx/dalpha'
12219       write (iout,'(a)')
12220       do i=2,nres-1
12221       alphi=alph(i)
12222       alph(i)=alph(i)+aincr
12223       do k=1,3
12224         temp(k,i)=dc(k,nres+i)
12225         enddo
12226       call chainbuild
12227       do k=1,3
12228         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12229         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
12230         enddo
12231         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12232         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
12233         write (iout,'(a)')
12234       alph(i)=alphi
12235       call chainbuild
12236       enddo
12237       write (iout,'(a)')
12238       write (iout,'(a)') '**************** dx/domega'
12239       write (iout,'(a)')
12240       do i=2,nres-1
12241       omegi=omeg(i)
12242       omeg(i)=omeg(i)+aincr
12243       do k=1,3
12244         temp(k,i)=dc(k,nres+i)
12245         enddo
12246       call chainbuild
12247       do k=1,3
12248           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12249           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
12250                 (aincr*dabs(dxds(k+3,i))+aincr))
12251         enddo
12252         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12253             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
12254         write (iout,'(a)')
12255       omeg(i)=omegi
12256       call chainbuild
12257       enddo
12258       write (iout,'(a)')
12259       write (iout,'(a)') '**************** dx/dtheta'
12260       write (iout,'(a)')
12261       do i=3,nres
12262       theti=theta(i)
12263         theta(i)=theta(i)+aincr
12264         do j=i-1,nres-1
12265           do k=1,3
12266             temp(k,j)=dc(k,nres+j)
12267           enddo
12268         enddo
12269         call chainbuild
12270         do j=i-1,nres-1
12271         ii = indmat(i-2,j)
12272 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
12273         do k=1,3
12274           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12275           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
12276                   (aincr*dabs(dxdv(k,ii))+aincr))
12277           enddo
12278           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12279               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
12280           write(iout,'(a)')
12281         enddo
12282         write (iout,'(a)')
12283         theta(i)=theti
12284         call chainbuild
12285       enddo
12286       write (iout,'(a)') '***************** dx/dphi'
12287       write (iout,'(a)')
12288       do i=4,nres
12289         phi(i)=phi(i)+aincr
12290         do j=i-1,nres-1
12291           do k=1,3
12292             temp(k,j)=dc(k,nres+j)
12293           enddo
12294         enddo
12295         call chainbuild
12296         do j=i-1,nres-1
12297         ii = indmat(i-2,j)
12298 !         print *,'ii=',ii
12299         do k=1,3
12300           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12301             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
12302                   (aincr*dabs(dxdv(k+3,ii))+aincr))
12303           enddo
12304           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12305               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12306           write(iout,'(a)')
12307         enddo
12308         phi(i)=phi(i)-aincr
12309         call chainbuild
12310       enddo
12311       write (iout,'(a)') '****************** ddc/dtheta'
12312       do i=1,nres-2
12313         thet=theta(i+2)
12314         theta(i+2)=thet+aincr
12315         do j=i,nres
12316           do k=1,3
12317             temp(k,j)=dc(k,j)
12318           enddo
12319         enddo
12320         call chainbuild
12321         do j=i+1,nres-1
12322         ii = indmat(i,j)
12323 !         print *,'ii=',ii
12324         do k=1,3
12325           gg(k)=(dc(k,j)-temp(k,j))/aincr
12326           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
12327                  (aincr*dabs(dcdv(k,ii))+aincr))
12328           enddo
12329           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12330                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
12331         write (iout,'(a)')
12332         enddo
12333         do j=1,nres
12334           do k=1,3
12335             dc(k,j)=temp(k,j)
12336           enddo
12337         enddo
12338         theta(i+2)=thet
12339       enddo
12340       write (iout,'(a)') '******************* ddc/dphi'
12341       do i=1,nres-3
12342         phii=phi(i+3)
12343         phi(i+3)=phii+aincr
12344         do j=1,nres
12345           do k=1,3
12346             temp(k,j)=dc(k,j)
12347           enddo
12348         enddo
12349         call chainbuild
12350         do j=i+2,nres-1
12351         ii = indmat(i+1,j)
12352 !         print *,'ii=',ii
12353         do k=1,3
12354           gg(k)=(dc(k,j)-temp(k,j))/aincr
12355             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
12356                  (aincr*dabs(dcdv(k+3,ii))+aincr))
12357           enddo
12358           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12359                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12360         write (iout,'(a)')
12361         enddo
12362         do j=1,nres
12363           do k=1,3
12364             dc(k,j)=temp(k,j)
12365           enddo
12366         enddo
12367         phi(i+3)=phii
12368       enddo
12369       return
12370       end subroutine check_cartgrad
12371 !-----------------------------------------------------------------------------
12372       subroutine check_ecart
12373 ! Check the gradient of the energy in Cartesian coordinates.
12374 !     implicit real*8 (a-h,o-z)
12375 !     include 'DIMENSIONS'
12376 !     include 'COMMON.CHAIN'
12377 !     include 'COMMON.DERIV'
12378 !     include 'COMMON.IOUNITS'
12379 !     include 'COMMON.VAR'
12380 !     include 'COMMON.CONTACTS'
12381       use comm_srutu
12382 !el      integer :: icall
12383 !el      common /srutu/ icall
12384       real(kind=8),dimension(6) :: ggg
12385       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12386       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12387       real(kind=8),dimension(6,nres) :: grad_s
12388       real(kind=8),dimension(0:n_ene) :: energia,energia1
12389       integer :: uiparm(1)
12390       real(kind=8) :: urparm(1)
12391 !EL      external fdum
12392       integer :: nf,i,j,k
12393       real(kind=8) :: aincr,etot,etot1
12394       icg=1
12395       nf=0
12396       nfl=0
12397       call zerograd
12398       aincr=1.0D-5
12399       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
12400       nf=0
12401       icall=0
12402       call geom_to_var(nvar,x)
12403       call etotal(energia)
12404       etot=energia(0)
12405 !el      call enerprint(energia)
12406       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
12407       icall =1
12408       do i=1,nres
12409         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12410       enddo
12411       do i=1,nres
12412       do j=1,3
12413         grad_s(j,i)=gradc(j,i,icg)
12414         grad_s(j+3,i)=gradx(j,i,icg)
12415         enddo
12416       enddo
12417       call flush(iout)
12418       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12419       do i=1,nres
12420         do j=1,3
12421         xx(j)=c(j,i+nres)
12422         ddc(j)=dc(j,i)
12423         ddx(j)=dc(j,i+nres)
12424         enddo
12425       do j=1,3
12426         dc(j,i)=dc(j,i)+aincr
12427         do k=i+1,nres
12428           c(j,k)=c(j,k)+aincr
12429           c(j,k+nres)=c(j,k+nres)+aincr
12430           enddo
12431           call zerograd
12432           call etotal(energia1)
12433           etot1=energia1(0)
12434         ggg(j)=(etot1-etot)/aincr
12435         dc(j,i)=ddc(j)
12436         do k=i+1,nres
12437           c(j,k)=c(j,k)-aincr
12438           c(j,k+nres)=c(j,k+nres)-aincr
12439           enddo
12440         enddo
12441       do j=1,3
12442         c(j,i+nres)=c(j,i+nres)+aincr
12443         dc(j,i+nres)=dc(j,i+nres)+aincr
12444           call zerograd
12445           call etotal(energia1)
12446           etot1=energia1(0)
12447         ggg(j+3)=(etot1-etot)/aincr
12448         c(j,i+nres)=xx(j)
12449         dc(j,i+nres)=ddx(j)
12450         enddo
12451       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
12452          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
12453       enddo
12454       return
12455       end subroutine check_ecart
12456 #ifdef CARGRAD
12457 !-----------------------------------------------------------------------------
12458       subroutine check_ecartint
12459 ! Check the gradient of the energy in Cartesian coordinates.
12460       use io_base, only: intout
12461 !      implicit real*8 (a-h,o-z)
12462 !      include 'DIMENSIONS'
12463 !      include 'COMMON.CONTROL'
12464 !      include 'COMMON.CHAIN'
12465 !      include 'COMMON.DERIV'
12466 !      include 'COMMON.IOUNITS'
12467 !      include 'COMMON.VAR'
12468 !      include 'COMMON.CONTACTS'
12469 !      include 'COMMON.MD'
12470 !      include 'COMMON.LOCAL'
12471 !      include 'COMMON.SPLITELE'
12472       use comm_srutu
12473 !el      integer :: icall
12474 !el      common /srutu/ icall
12475       real(kind=8),dimension(6) :: ggg,ggg1
12476       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
12477       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12478       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
12479       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12480       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12481       real(kind=8),dimension(0:n_ene) :: energia,energia1
12482       integer :: uiparm(1)
12483       real(kind=8) :: urparm(1)
12484 !EL      external fdum
12485       integer :: i,j,k,nf
12486       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12487                    etot21,etot22
12488       r_cut=2.0d0
12489       rlambd=0.3d0
12490       icg=1
12491       nf=0
12492       nfl=0
12493       call intout
12494 !      call intcartderiv
12495 !      call checkintcartgrad
12496       call zerograd
12497       aincr=1.0D-5
12498       write(iout,*) 'Calling CHECK_ECARTINT.'
12499       nf=0
12500       icall=0
12501       call geom_to_var(nvar,x)
12502       write (iout,*) "split_ene ",split_ene
12503       call flush(iout)
12504       if (.not.split_ene) then
12505         call zerograd
12506         call etotal(energia)
12507         etot=energia(0)
12508         call cartgrad
12509         icall =1
12510         do i=1,nres
12511           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12512         enddo
12513         do j=1,3
12514           grad_s(j,0)=gcart(j,0)
12515         enddo
12516         do i=1,nres
12517           do j=1,3
12518             grad_s(j,i)=gcart(j,i)
12519             grad_s(j+3,i)=gxcart(j,i)
12520           enddo
12521         enddo
12522       else
12523 !- split gradient check
12524         call zerograd
12525         call etotal_long(energia)
12526 !el        call enerprint(energia)
12527         call cartgrad
12528         icall =1
12529         do i=1,nres
12530           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12531           (gxcart(j,i),j=1,3)
12532         enddo
12533         do j=1,3
12534           grad_s(j,0)=gcart(j,0)
12535         enddo
12536         do i=1,nres
12537           do j=1,3
12538             grad_s(j,i)=gcart(j,i)
12539             grad_s(j+3,i)=gxcart(j,i)
12540           enddo
12541         enddo
12542         call zerograd
12543         call etotal_short(energia)
12544         call enerprint(energia)
12545         call cartgrad
12546         icall =1
12547         do i=1,nres
12548           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12549           (gxcart(j,i),j=1,3)
12550         enddo
12551         do j=1,3
12552           grad_s1(j,0)=gcart(j,0)
12553         enddo
12554         do i=1,nres
12555           do j=1,3
12556             grad_s1(j,i)=gcart(j,i)
12557             grad_s1(j+3,i)=gxcart(j,i)
12558           enddo
12559         enddo
12560       endif
12561       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12562 !      do i=1,nres
12563       do i=nnt,nct
12564         do j=1,3
12565           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
12566           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
12567         ddc(j)=c(j,i)
12568         ddx(j)=c(j,i+nres)
12569           dcnorm_safe1(j)=dc_norm(j,i-1)
12570           dcnorm_safe2(j)=dc_norm(j,i)
12571           dxnorm_safe(j)=dc_norm(j,i+nres)
12572         enddo
12573       do j=1,3
12574         c(j,i)=ddc(j)+aincr
12575           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
12576           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
12577           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12578           dc(j,i)=c(j,i+1)-c(j,i)
12579           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12580           call int_from_cart1(.false.)
12581           if (.not.split_ene) then
12582            call zerograd
12583             call etotal(energia1)
12584             etot1=energia1(0)
12585             write (iout,*) "ij",i,j," etot1",etot1
12586           else
12587 !- split gradient
12588             call etotal_long(energia1)
12589             etot11=energia1(0)
12590             call etotal_short(energia1)
12591             etot12=energia1(0)
12592           endif
12593 !- end split gradient
12594 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12595         c(j,i)=ddc(j)-aincr
12596           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
12597           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
12598           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12599           dc(j,i)=c(j,i+1)-c(j,i)
12600           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12601           call int_from_cart1(.false.)
12602           if (.not.split_ene) then
12603             call zerograd
12604             call etotal(energia1)
12605             etot2=energia1(0)
12606             write (iout,*) "ij",i,j," etot2",etot2
12607           ggg(j)=(etot1-etot2)/(2*aincr)
12608           else
12609 !- split gradient
12610             call etotal_long(energia1)
12611             etot21=energia1(0)
12612           ggg(j)=(etot11-etot21)/(2*aincr)
12613             call etotal_short(energia1)
12614             etot22=energia1(0)
12615           ggg1(j)=(etot12-etot22)/(2*aincr)
12616 !- end split gradient
12617 !            write (iout,*) "etot21",etot21," etot22",etot22
12618           endif
12619 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12620         c(j,i)=ddc(j)
12621           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
12622           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
12623           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12624           dc(j,i)=c(j,i+1)-c(j,i)
12625           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12626           dc_norm(j,i-1)=dcnorm_safe1(j)
12627           dc_norm(j,i)=dcnorm_safe2(j)
12628           dc_norm(j,i+nres)=dxnorm_safe(j)
12629         enddo
12630       do j=1,3
12631         c(j,i+nres)=ddx(j)+aincr
12632           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12633           call int_from_cart1(.false.)
12634           if (.not.split_ene) then
12635             call zerograd
12636             call etotal(energia1)
12637             etot1=energia1(0)
12638           else
12639 !- split gradient
12640             call etotal_long(energia1)
12641             etot11=energia1(0)
12642             call etotal_short(energia1)
12643             etot12=energia1(0)
12644           endif
12645 !- end split gradient
12646         c(j,i+nres)=ddx(j)-aincr
12647           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12648           call int_from_cart1(.false.)
12649           if (.not.split_ene) then
12650            call zerograd
12651            call etotal(energia1)
12652             etot2=energia1(0)
12653           ggg(j+3)=(etot1-etot2)/(2*aincr)
12654           else
12655 !- split gradient
12656             call etotal_long(energia1)
12657             etot21=energia1(0)
12658           ggg(j+3)=(etot11-etot21)/(2*aincr)
12659             call etotal_short(energia1)
12660             etot22=energia1(0)
12661           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12662 !- end split gradient
12663           endif
12664 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12665         c(j,i+nres)=ddx(j)
12666           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12667           dc_norm(j,i+nres)=dxnorm_safe(j)
12668           call int_from_cart1(.false.)
12669         enddo
12670       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12671          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12672         if (split_ene) then
12673           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12674          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12675          k=1,6)
12676          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12677          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12678          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12679         endif
12680       enddo
12681       return
12682       end subroutine check_ecartint
12683 #else
12684 !-----------------------------------------------------------------------------
12685       subroutine check_ecartint
12686 ! Check the gradient of the energy in Cartesian coordinates.
12687       use io_base, only: intout
12688 !      implicit real*8 (a-h,o-z)
12689 !      include 'DIMENSIONS'
12690 !      include 'COMMON.CONTROL'
12691 !      include 'COMMON.CHAIN'
12692 !      include 'COMMON.DERIV'
12693 !      include 'COMMON.IOUNITS'
12694 !      include 'COMMON.VAR'
12695 !      include 'COMMON.CONTACTS'
12696 !      include 'COMMON.MD'
12697 !      include 'COMMON.LOCAL'
12698 !      include 'COMMON.SPLITELE'
12699       use comm_srutu
12700 !el      integer :: icall
12701 !el      common /srutu/ icall
12702       real(kind=8),dimension(6) :: ggg,ggg1
12703       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12704       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12705       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
12706       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12707       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12708       real(kind=8),dimension(0:n_ene) :: energia,energia1
12709       integer :: uiparm(1)
12710       real(kind=8) :: urparm(1)
12711 !EL      external fdum
12712       integer :: i,j,k,nf
12713       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12714                    etot21,etot22
12715       r_cut=2.0d0
12716       rlambd=0.3d0
12717       icg=1
12718       nf=0
12719       nfl=0
12720       call intout
12721 !      call intcartderiv
12722 !      call checkintcartgrad
12723       call zerograd
12724       aincr=1.0D-6
12725       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
12726       nf=0
12727       icall=0
12728       call geom_to_var(nvar,x)
12729       if (.not.split_ene) then
12730         call etotal(energia)
12731         etot=energia(0)
12732 !el        call enerprint(energia)
12733         call cartgrad
12734         icall =1
12735         do i=1,nres
12736           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12737         enddo
12738         do j=1,3
12739           grad_s(j,0)=gcart(j,0)
12740         enddo
12741         do i=1,nres
12742           do j=1,3
12743             grad_s(j,i)=gcart(j,i)
12744 !              if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12745
12746 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
12747             grad_s(j+3,i)=gxcart(j,i)
12748           enddo
12749         enddo
12750       else
12751 !- split gradient check
12752         call zerograd
12753         call etotal_long(energia)
12754 !el        call enerprint(energia)
12755         call cartgrad
12756         icall =1
12757         do i=1,nres
12758           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12759           (gxcart(j,i),j=1,3)
12760         enddo
12761         do j=1,3
12762           grad_s(j,0)=gcart(j,0)
12763         enddo
12764         do i=1,nres
12765           do j=1,3
12766             grad_s(j,i)=gcart(j,i)
12767 !            if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12768             grad_s(j+3,i)=gxcart(j,i)
12769           enddo
12770         enddo
12771         call zerograd
12772         call etotal_short(energia)
12773 !el        call enerprint(energia)
12774         call cartgrad
12775         icall =1
12776         do i=1,nres
12777           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12778           (gxcart(j,i),j=1,3)
12779         enddo
12780         do j=1,3
12781           grad_s1(j,0)=gcart(j,0)
12782         enddo
12783         do i=1,nres
12784           do j=1,3
12785             grad_s1(j,i)=gcart(j,i)
12786             grad_s1(j+3,i)=gxcart(j,i)
12787           enddo
12788         enddo
12789       endif
12790       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12791       do i=0,nres
12792         do j=1,3
12793         xx(j)=c(j,i+nres)
12794         ddc(j)=dc(j,i)
12795         ddx(j)=dc(j,i+nres)
12796           do k=1,3
12797             dcnorm_safe(k)=dc_norm(k,i)
12798             dxnorm_safe(k)=dc_norm(k,i+nres)
12799           enddo
12800         enddo
12801       do j=1,3
12802         dc(j,i)=ddc(j)+aincr
12803           call chainbuild_cart
12804 #ifdef MPI
12805 ! Broadcast the order to compute internal coordinates to the slaves.
12806 !          if (nfgtasks.gt.1)
12807 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12808 #endif
12809 !          call int_from_cart1(.false.)
12810           if (.not.split_ene) then
12811            call zerograd
12812             call etotal(energia1)
12813             etot1=energia1(0)
12814 !            call enerprint(energia1)
12815           else
12816 !- split gradient
12817             call etotal_long(energia1)
12818             etot11=energia1(0)
12819             call etotal_short(energia1)
12820             etot12=energia1(0)
12821 !            write (iout,*) "etot11",etot11," etot12",etot12
12822           endif
12823 !- end split gradient
12824 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12825         dc(j,i)=ddc(j)-aincr
12826           call chainbuild_cart
12827 !          call int_from_cart1(.false.)
12828           if (.not.split_ene) then
12829                   call zerograd
12830             call etotal(energia1)
12831             etot2=energia1(0)
12832           ggg(j)=(etot1-etot2)/(2*aincr)
12833           else
12834 !- split gradient
12835             call etotal_long(energia1)
12836             etot21=energia1(0)
12837           ggg(j)=(etot11-etot21)/(2*aincr)
12838             call etotal_short(energia1)
12839             etot22=energia1(0)
12840           ggg1(j)=(etot12-etot22)/(2*aincr)
12841 !- end split gradient
12842 !            write (iout,*) "etot21",etot21," etot22",etot22
12843           endif
12844 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12845         dc(j,i)=ddc(j)
12846           call chainbuild_cart
12847         enddo
12848       do j=1,3
12849         dc(j,i+nres)=ddx(j)+aincr
12850           call chainbuild_cart
12851 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
12852 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12853 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12854 !          write (iout,*) "dxnormnorm",dsqrt(
12855 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12856 !          write (iout,*) "dxnormnormsafe",dsqrt(
12857 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12858 !          write (iout,*)
12859           if (.not.split_ene) then
12860             call zerograd
12861             call etotal(energia1)
12862             etot1=energia1(0)
12863           else
12864 !- split gradient
12865             call etotal_long(energia1)
12866             etot11=energia1(0)
12867             call etotal_short(energia1)
12868             etot12=energia1(0)
12869           endif
12870 !- end split gradient
12871 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12872         dc(j,i+nres)=ddx(j)-aincr
12873           call chainbuild_cart
12874 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
12875 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12876 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12877 !          write (iout,*)
12878 !          write (iout,*) "dxnormnorm",dsqrt(
12879 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12880 !          write (iout,*) "dxnormnormsafe",dsqrt(
12881 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12882           if (.not.split_ene) then
12883             call zerograd
12884             call etotal(energia1)
12885             etot2=energia1(0)
12886           ggg(j+3)=(etot1-etot2)/(2*aincr)
12887           else
12888 !- split gradient
12889             call etotal_long(energia1)
12890             etot21=energia1(0)
12891           ggg(j+3)=(etot11-etot21)/(2*aincr)
12892             call etotal_short(energia1)
12893             etot22=energia1(0)
12894           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12895 !- end split gradient
12896           endif
12897 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12898         dc(j,i+nres)=ddx(j)
12899           call chainbuild_cart
12900         enddo
12901       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12902          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12903         if (split_ene) then
12904           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12905          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12906          k=1,6)
12907          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12908          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12909          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12910         endif
12911       enddo
12912       return
12913       end subroutine check_ecartint
12914 #endif
12915 !-----------------------------------------------------------------------------
12916       subroutine check_eint
12917 ! Check the gradient of energy in internal coordinates.
12918 !      implicit real*8 (a-h,o-z)
12919 !      include 'DIMENSIONS'
12920 !      include 'COMMON.CHAIN'
12921 !      include 'COMMON.DERIV'
12922 !      include 'COMMON.IOUNITS'
12923 !      include 'COMMON.VAR'
12924 !      include 'COMMON.GEO'
12925       use comm_srutu
12926 !el      integer :: icall
12927 !el      common /srutu/ icall
12928       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
12929       integer :: uiparm(1)
12930       real(kind=8) :: urparm(1)
12931       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
12932       character(len=6) :: key
12933 !EL      external fdum
12934       integer :: i,ii,nf
12935       real(kind=8) :: xi,aincr,etot,etot1,etot2
12936       call zerograd
12937       aincr=1.0D-7
12938       print '(a)','Calling CHECK_INT.'
12939       nf=0
12940       nfl=0
12941       icg=1
12942       call geom_to_var(nvar,x)
12943       call var_to_geom(nvar,x)
12944       call chainbuild
12945       icall=1
12946 !      print *,'ICG=',ICG
12947       call etotal(energia)
12948       etot = energia(0)
12949 !el      call enerprint(energia)
12950 !      print *,'ICG=',ICG
12951 #ifdef MPL
12952       if (MyID.ne.BossID) then
12953         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
12954         nf=x(nvar+1)
12955         nfl=x(nvar+2)
12956         icg=x(nvar+3)
12957       endif
12958 #endif
12959       nf=1
12960       nfl=3
12961 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
12962       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
12963 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
12964       icall=1
12965       do i=1,nvar
12966         xi=x(i)
12967         x(i)=xi-0.5D0*aincr
12968         call var_to_geom(nvar,x)
12969         call chainbuild
12970         call etotal(energia1)
12971         etot1=energia1(0)
12972         x(i)=xi+0.5D0*aincr
12973         call var_to_geom(nvar,x)
12974         call chainbuild
12975         call etotal(energia2)
12976         etot2=energia2(0)
12977         gg(i)=(etot2-etot1)/aincr
12978         write (iout,*) i,etot1,etot2
12979         x(i)=xi
12980       enddo
12981       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
12982           '     RelDiff*100% '
12983       do i=1,nvar
12984         if (i.le.nphi) then
12985           ii=i
12986           key = ' phi'
12987         else if (i.le.nphi+ntheta) then
12988           ii=i-nphi
12989           key=' theta'
12990         else if (i.le.nphi+ntheta+nside) then
12991            ii=i-(nphi+ntheta)
12992            key=' alpha'
12993         else
12994            ii=i-(nphi+ntheta+nside)
12995            key=' omega'
12996         endif
12997         write (iout,'(i3,a,i3,3(1pd16.6))') &
12998        i,key,ii,gg(i),gana(i),&
12999        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
13000       enddo
13001       return
13002       end subroutine check_eint
13003 !-----------------------------------------------------------------------------
13004 ! econstr_local.F
13005 !-----------------------------------------------------------------------------
13006       subroutine Econstr_back
13007 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
13008 !      implicit real*8 (a-h,o-z)
13009 !      include 'DIMENSIONS'
13010 !      include 'COMMON.CONTROL'
13011 !      include 'COMMON.VAR'
13012 !      include 'COMMON.MD'
13013       use MD_data
13014 !#ifndef LANG0
13015 !      include 'COMMON.LANGEVIN'
13016 !#else
13017 !      include 'COMMON.LANGEVIN.lang0'
13018 !#endif
13019 !      include 'COMMON.CHAIN'
13020 !      include 'COMMON.DERIV'
13021 !      include 'COMMON.GEO'
13022 !      include 'COMMON.LOCAL'
13023 !      include 'COMMON.INTERACT'
13024 !      include 'COMMON.IOUNITS'
13025 !      include 'COMMON.NAMES'
13026 !      include 'COMMON.TIME1'
13027       integer :: i,j,ii,k
13028       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
13029
13030       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
13031       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
13032       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
13033
13034       Uconst_back=0.0d0
13035       do i=1,nres
13036         dutheta(i)=0.0d0
13037         dugamma(i)=0.0d0
13038         do j=1,3
13039           duscdiff(j,i)=0.0d0
13040           duscdiffx(j,i)=0.0d0
13041         enddo
13042       enddo
13043       do i=1,nfrag_back
13044         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
13045 !
13046 ! Deviations from theta angles
13047 !
13048         utheta_i=0.0d0
13049         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
13050           dtheta_i=theta(j)-thetaref(j)
13051           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
13052           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
13053         enddo
13054         utheta(i)=utheta_i/(ii-1)
13055 !
13056 ! Deviations from gamma angles
13057 !
13058         ugamma_i=0.0d0
13059         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
13060           dgamma_i=pinorm(phi(j)-phiref(j))
13061 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
13062           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
13063           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
13064 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
13065         enddo
13066         ugamma(i)=ugamma_i/(ii-2)
13067 !
13068 ! Deviations from local SC geometry
13069 !
13070         uscdiff(i)=0.0d0
13071         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
13072           dxx=xxtab(j)-xxref(j)
13073           dyy=yytab(j)-yyref(j)
13074           dzz=zztab(j)-zzref(j)
13075           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
13076           do k=1,3
13077             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
13078              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
13079              (ii-1)
13080             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
13081              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
13082              (ii-1)
13083             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
13084            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
13085             /(ii-1)
13086           enddo
13087 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
13088 !     &      xxref(j),yyref(j),zzref(j)
13089         enddo
13090         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
13091 !        write (iout,*) i," uscdiff",uscdiff(i)
13092 !
13093 ! Put together deviations from local geometry
13094 !
13095         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
13096           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
13097 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
13098 !     &   " uconst_back",uconst_back
13099         utheta(i)=dsqrt(utheta(i))
13100         ugamma(i)=dsqrt(ugamma(i))
13101         uscdiff(i)=dsqrt(uscdiff(i))
13102       enddo
13103       return
13104       end subroutine Econstr_back
13105 !-----------------------------------------------------------------------------
13106 ! energy_p_new-sep_barrier.F
13107 !-----------------------------------------------------------------------------
13108       real(kind=8) function sscale(r)
13109 !      include "COMMON.SPLITELE"
13110       real(kind=8) :: r,gamm
13111       if(r.lt.r_cut-rlamb) then
13112         sscale=1.0d0
13113       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13114         gamm=(r-(r_cut-rlamb))/rlamb
13115         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13116       else
13117         sscale=0d0
13118       endif
13119       return
13120       end function sscale
13121       real(kind=8) function sscale_grad(r)
13122 !      include "COMMON.SPLITELE"
13123       real(kind=8) :: r,gamm
13124       if(r.lt.r_cut-rlamb) then
13125         sscale_grad=0.0d0
13126       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13127         gamm=(r-(r_cut-rlamb))/rlamb
13128         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
13129       else
13130         sscale_grad=0d0
13131       endif
13132       return
13133       end function sscale_grad
13134
13135 !!!!!!!!!! PBCSCALE
13136       real(kind=8) function sscale_ele(r)
13137 !      include "COMMON.SPLITELE"
13138       real(kind=8) :: r,gamm
13139       if(r.lt.r_cut_ele-rlamb_ele) then
13140         sscale_ele=1.0d0
13141       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13142         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13143         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13144       else
13145         sscale_ele=0d0
13146       endif
13147       return
13148       end function sscale_ele
13149
13150       real(kind=8)  function sscagrad_ele(r)
13151       real(kind=8) :: r,gamm
13152 !      include "COMMON.SPLITELE"
13153       if(r.lt.r_cut_ele-rlamb_ele) then
13154         sscagrad_ele=0.0d0
13155       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13156         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13157         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
13158       else
13159         sscagrad_ele=0.0d0
13160       endif
13161       return
13162       end function sscagrad_ele
13163       real(kind=8) function sscalelip(r)
13164       real(kind=8) r,gamm
13165         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
13166       return
13167       end function sscalelip
13168 !C-----------------------------------------------------------------------
13169       real(kind=8) function sscagradlip(r)
13170       real(kind=8) r,gamm
13171         sscagradlip=r*(6.0d0*r-6.0d0)
13172       return
13173       end function sscagradlip
13174
13175 !!!!!!!!!!!!!!!
13176 !-----------------------------------------------------------------------------
13177       subroutine elj_long(evdw)
13178 !
13179 ! This subroutine calculates the interaction energy of nonbonded side chains
13180 ! assuming the LJ potential of interaction.
13181 !
13182 !      implicit real*8 (a-h,o-z)
13183 !      include 'DIMENSIONS'
13184 !      include 'COMMON.GEO'
13185 !      include 'COMMON.VAR'
13186 !      include 'COMMON.LOCAL'
13187 !      include 'COMMON.CHAIN'
13188 !      include 'COMMON.DERIV'
13189 !      include 'COMMON.INTERACT'
13190 !      include 'COMMON.TORSION'
13191 !      include 'COMMON.SBRIDGE'
13192 !      include 'COMMON.NAMES'
13193 !      include 'COMMON.IOUNITS'
13194 !      include 'COMMON.CONTACTS'
13195       real(kind=8),parameter :: accur=1.0d-10
13196       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13197 !el local variables
13198       integer :: i,iint,j,k,itypi,itypi1,itypj
13199       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13200       real(kind=8) :: e1,e2,evdwij,evdw,sslipi,ssgradlipi,&
13201                       sslipj,ssgradlipj,aa,bb
13202 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13203       evdw=0.0D0
13204       do i=iatsc_s,iatsc_e
13205         itypi=itype(i,1)
13206         if (itypi.eq.ntyp1) cycle
13207         itypi1=itype(i+1,1)
13208         xi=c(1,nres+i)
13209         yi=c(2,nres+i)
13210         zi=c(3,nres+i)
13211         call to_box(xi,yi,zi)
13212         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13213 !
13214 ! Calculate SC interaction energy.
13215 !
13216         do iint=1,nint_gr(i)
13217 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13218 !d   &                  'iend=',iend(i,iint)
13219           do j=istart(i,iint),iend(i,iint)
13220             itypj=itype(j,1)
13221             if (itypj.eq.ntyp1) cycle
13222             xj=c(1,nres+j)-xi
13223             yj=c(2,nres+j)-yi
13224             zj=c(3,nres+j)-zi
13225             call to_box(xj,yj,zj)
13226             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13227             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13228              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13229             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13230              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13231             xj=boxshift(xj-xi,boxxsize)
13232             yj=boxshift(yj-yi,boxysize)
13233             zj=boxshift(zj-zi,boxzsize)
13234             rij=xj*xj+yj*yj+zj*zj
13235             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13236             if (sss.lt.1.0d0) then
13237               rrij=1.0D0/rij
13238               eps0ij=eps(itypi,itypj)
13239               fac=rrij**expon2
13240               e1=fac*fac*aa_aq(itypi,itypj)
13241               e2=fac*bb_aq(itypi,itypj)
13242               evdwij=e1+e2
13243               evdw=evdw+(1.0d0-sss)*evdwij
13244 !
13245 ! Calculate the components of the gradient in DC and X
13246 !
13247               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
13248               gg(1)=xj*fac
13249               gg(2)=yj*fac
13250               gg(3)=zj*fac
13251               do k=1,3
13252                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13253                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13254                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13255                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13256               enddo
13257             endif
13258           enddo      ! j
13259         enddo        ! iint
13260       enddo          ! i
13261       do i=1,nct
13262         do j=1,3
13263           gvdwc(j,i)=expon*gvdwc(j,i)
13264           gvdwx(j,i)=expon*gvdwx(j,i)
13265         enddo
13266       enddo
13267 !******************************************************************************
13268 !
13269 !                              N O T E !!!
13270 !
13271 ! To save time, the factor of EXPON has been extracted from ALL components
13272 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13273 ! use!
13274 !
13275 !******************************************************************************
13276       return
13277       end subroutine elj_long
13278 !-----------------------------------------------------------------------------
13279       subroutine elj_short(evdw)
13280 !
13281 ! This subroutine calculates the interaction energy of nonbonded side chains
13282 ! assuming the LJ potential of interaction.
13283 !
13284 !      implicit real*8 (a-h,o-z)
13285 !      include 'DIMENSIONS'
13286 !      include 'COMMON.GEO'
13287 !      include 'COMMON.VAR'
13288 !      include 'COMMON.LOCAL'
13289 !      include 'COMMON.CHAIN'
13290 !      include 'COMMON.DERIV'
13291 !      include 'COMMON.INTERACT'
13292 !      include 'COMMON.TORSION'
13293 !      include 'COMMON.SBRIDGE'
13294 !      include 'COMMON.NAMES'
13295 !      include 'COMMON.IOUNITS'
13296 !      include 'COMMON.CONTACTS'
13297       real(kind=8),parameter :: accur=1.0d-10
13298       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13299 !el local variables
13300       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
13301       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13302       real(kind=8) :: e1,e2,evdwij,evdw,sslipi,ssgradlipi,&
13303                       sslipj,ssgradlipj
13304 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13305       evdw=0.0D0
13306       do i=iatsc_s,iatsc_e
13307         itypi=itype(i,1)
13308         if (itypi.eq.ntyp1) cycle
13309         itypi1=itype(i+1,1)
13310         xi=c(1,nres+i)
13311         yi=c(2,nres+i)
13312         zi=c(3,nres+i)
13313         call to_box(xi,yi,zi)
13314         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13315 ! Change 12/1/95
13316         num_conti=0
13317 !
13318 ! Calculate SC interaction energy.
13319 !
13320         do iint=1,nint_gr(i)
13321 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13322 !d   &                  'iend=',iend(i,iint)
13323           do j=istart(i,iint),iend(i,iint)
13324             itypj=itype(j,1)
13325             if (itypj.eq.ntyp1) cycle
13326             xj=c(1,nres+j)-xi
13327             yj=c(2,nres+j)-yi
13328             zj=c(3,nres+j)-zi
13329 ! Change 12/1/95 to calculate four-body interactions
13330             rij=xj*xj+yj*yj+zj*zj
13331             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13332             if (sss.gt.0.0d0) then
13333               rrij=1.0D0/rij
13334               eps0ij=eps(itypi,itypj)
13335               fac=rrij**expon2
13336               e1=fac*fac*aa_aq(itypi,itypj)
13337               e2=fac*bb_aq(itypi,itypj)
13338               evdwij=e1+e2
13339               evdw=evdw+sss*evdwij
13340 !
13341 ! Calculate the components of the gradient in DC and X
13342 !
13343               fac=-rrij*(e1+evdwij)*sss
13344               gg(1)=xj*fac
13345               gg(2)=yj*fac
13346               gg(3)=zj*fac
13347               do k=1,3
13348                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13349                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13350                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13351                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13352               enddo
13353             endif
13354           enddo      ! j
13355         enddo        ! iint
13356       enddo          ! i
13357       do i=1,nct
13358         do j=1,3
13359           gvdwc(j,i)=expon*gvdwc(j,i)
13360           gvdwx(j,i)=expon*gvdwx(j,i)
13361         enddo
13362       enddo
13363 !******************************************************************************
13364 !
13365 !                              N O T E !!!
13366 !
13367 ! To save time, the factor of EXPON has been extracted from ALL components
13368 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13369 ! use!
13370 !
13371 !******************************************************************************
13372       return
13373       end subroutine elj_short
13374 !-----------------------------------------------------------------------------
13375       subroutine eljk_long(evdw)
13376 !
13377 ! This subroutine calculates the interaction energy of nonbonded side chains
13378 ! assuming the LJK potential of interaction.
13379 !
13380 !      implicit real*8 (a-h,o-z)
13381 !      include 'DIMENSIONS'
13382 !      include 'COMMON.GEO'
13383 !      include 'COMMON.VAR'
13384 !      include 'COMMON.LOCAL'
13385 !      include 'COMMON.CHAIN'
13386 !      include 'COMMON.DERIV'
13387 !      include 'COMMON.INTERACT'
13388 !      include 'COMMON.IOUNITS'
13389 !      include 'COMMON.NAMES'
13390       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13391       logical :: scheck
13392 !el local variables
13393       integer :: i,iint,j,k,itypi,itypi1,itypj
13394       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13395                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
13396 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13397       evdw=0.0D0
13398       do i=iatsc_s,iatsc_e
13399         itypi=itype(i,1)
13400         if (itypi.eq.ntyp1) cycle
13401         itypi1=itype(i+1,1)
13402         xi=c(1,nres+i)
13403         yi=c(2,nres+i)
13404         zi=c(3,nres+i)
13405           call to_box(xi,yi,zi)
13406
13407 !
13408 ! Calculate SC interaction energy.
13409 !
13410         do iint=1,nint_gr(i)
13411           do j=istart(i,iint),iend(i,iint)
13412             itypj=itype(j,1)
13413             if (itypj.eq.ntyp1) cycle
13414             xj=c(1,nres+j)-xi
13415             yj=c(2,nres+j)-yi
13416             zj=c(3,nres+j)-zi
13417           call to_box(xj,yj,zj)
13418       xj=boxshift(xj-xi,boxxsize)
13419       yj=boxshift(yj-yi,boxysize)
13420       zj=boxshift(zj-zi,boxzsize)
13421
13422             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13423             fac_augm=rrij**expon
13424             e_augm=augm(itypi,itypj)*fac_augm
13425             r_inv_ij=dsqrt(rrij)
13426             rij=1.0D0/r_inv_ij
13427             sss=sscale(rij/sigma(itypi,itypj))
13428             if (sss.lt.1.0d0) then
13429               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13430               fac=r_shift_inv**expon
13431               e1=fac*fac*aa_aq(itypi,itypj)
13432               e2=fac*bb_aq(itypi,itypj)
13433               evdwij=e_augm+e1+e2
13434 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13435 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13436 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13437 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13438 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13439 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13440 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13441               evdw=evdw+(1.0d0-sss)*evdwij
13442 !
13443 ! Calculate the components of the gradient in DC and X
13444 !
13445               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13446               fac=fac*(1.0d0-sss)
13447               gg(1)=xj*fac
13448               gg(2)=yj*fac
13449               gg(3)=zj*fac
13450               do k=1,3
13451                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13452                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13453                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13454                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13455               enddo
13456             endif
13457           enddo      ! j
13458         enddo        ! iint
13459       enddo          ! i
13460       do i=1,nct
13461         do j=1,3
13462           gvdwc(j,i)=expon*gvdwc(j,i)
13463           gvdwx(j,i)=expon*gvdwx(j,i)
13464         enddo
13465       enddo
13466       return
13467       end subroutine eljk_long
13468 !-----------------------------------------------------------------------------
13469       subroutine eljk_short(evdw)
13470 !
13471 ! This subroutine calculates the interaction energy of nonbonded side chains
13472 ! assuming the LJK potential of interaction.
13473 !
13474 !      implicit real*8 (a-h,o-z)
13475 !      include 'DIMENSIONS'
13476 !      include 'COMMON.GEO'
13477 !      include 'COMMON.VAR'
13478 !      include 'COMMON.LOCAL'
13479 !      include 'COMMON.CHAIN'
13480 !      include 'COMMON.DERIV'
13481 !      include 'COMMON.INTERACT'
13482 !      include 'COMMON.IOUNITS'
13483 !      include 'COMMON.NAMES'
13484       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13485       logical :: scheck
13486 !el local variables
13487       integer :: i,iint,j,k,itypi,itypi1,itypj
13488       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13489                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij,&
13490                    sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
13491 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13492       evdw=0.0D0
13493       do i=iatsc_s,iatsc_e
13494         itypi=itype(i,1)
13495         if (itypi.eq.ntyp1) cycle
13496         itypi1=itype(i+1,1)
13497         xi=c(1,nres+i)
13498         yi=c(2,nres+i)
13499         zi=c(3,nres+i)
13500         call to_box(xi,yi,zi)
13501         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13502 !
13503 ! Calculate SC interaction energy.
13504 !
13505         do iint=1,nint_gr(i)
13506           do j=istart(i,iint),iend(i,iint)
13507             itypj=itype(j,1)
13508             if (itypj.eq.ntyp1) cycle
13509             xj=c(1,nres+j)-xi
13510             yj=c(2,nres+j)-yi
13511             zj=c(3,nres+j)-zi
13512             call to_box(xj,yj,zj)
13513             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13514             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13515              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13516             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13517              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13518             xj=boxshift(xj-xi,boxxsize)
13519             yj=boxshift(yj-yi,boxysize)
13520             zj=boxshift(zj-zi,boxzsize)
13521             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13522             fac_augm=rrij**expon
13523             e_augm=augm(itypi,itypj)*fac_augm
13524             r_inv_ij=dsqrt(rrij)
13525             rij=1.0D0/r_inv_ij
13526             sss=sscale(rij/sigma(itypi,itypj))
13527             if (sss.gt.0.0d0) then
13528               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13529               fac=r_shift_inv**expon
13530               e1=fac*fac*aa_aq(itypi,itypj)
13531               e2=fac*bb_aq(itypi,itypj)
13532               evdwij=e_augm+e1+e2
13533 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13534 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13535 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13536 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13537 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13538 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13539 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13540               evdw=evdw+sss*evdwij
13541 !
13542 ! Calculate the components of the gradient in DC and X
13543 !
13544               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13545               fac=fac*sss
13546               gg(1)=xj*fac
13547               gg(2)=yj*fac
13548               gg(3)=zj*fac
13549               do k=1,3
13550                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13551                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13552                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13553                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13554               enddo
13555             endif
13556           enddo      ! j
13557         enddo        ! iint
13558       enddo          ! i
13559       do i=1,nct
13560         do j=1,3
13561           gvdwc(j,i)=expon*gvdwc(j,i)
13562           gvdwx(j,i)=expon*gvdwx(j,i)
13563         enddo
13564       enddo
13565       return
13566       end subroutine eljk_short
13567 !-----------------------------------------------------------------------------
13568        subroutine ebp_long(evdw)
13569 ! This subroutine calculates the interaction energy of nonbonded side chains
13570 ! assuming the Berne-Pechukas potential of interaction.
13571 !
13572        use calc_data
13573 !      implicit real*8 (a-h,o-z)
13574 !      include 'DIMENSIONS'
13575 !      include 'COMMON.GEO'
13576 !      include 'COMMON.VAR'
13577 !      include 'COMMON.LOCAL'
13578 !      include 'COMMON.CHAIN'
13579 !      include 'COMMON.DERIV'
13580 !      include 'COMMON.NAMES'
13581 !      include 'COMMON.INTERACT'
13582 !      include 'COMMON.IOUNITS'
13583 !      include 'COMMON.CALC'
13584        use comm_srutu
13585 !el      integer :: icall
13586 !el      common /srutu/ icall
13587 !     double precision rrsave(maxdim)
13588         logical :: lprn
13589 !el local variables
13590         integer :: iint,itypi,itypi1,itypj
13591         real(kind=8) :: rrij,xi,yi,zi,fac,sslipi,ssgradlipi,&
13592                         sslipj,ssgradlipj,aa,bb
13593         real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
13594         evdw=0.0D0
13595 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13596         evdw=0.0D0
13597 !     if (icall.eq.0) then
13598 !       lprn=.true.
13599 !     else
13600       lprn=.false.
13601 !     endif
13602 !el      ind=0
13603       do i=iatsc_s,iatsc_e
13604       itypi=itype(i,1)
13605       if (itypi.eq.ntyp1) cycle
13606       itypi1=itype(i+1,1)
13607       xi=c(1,nres+i)
13608       yi=c(2,nres+i)
13609       zi=c(3,nres+i)
13610         call to_box(xi,yi,zi)
13611         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13612       dxi=dc_norm(1,nres+i)
13613       dyi=dc_norm(2,nres+i)
13614       dzi=dc_norm(3,nres+i)
13615 !        dsci_inv=dsc_inv(itypi)
13616       dsci_inv=vbld_inv(i+nres)
13617 !
13618 ! Calculate SC interaction energy.
13619 !
13620       do iint=1,nint_gr(i)
13621       do j=istart(i,iint),iend(i,iint)
13622 !el            ind=ind+1
13623       itypj=itype(j,1)
13624       if (itypj.eq.ntyp1) cycle
13625 !            dscj_inv=dsc_inv(itypj)
13626       dscj_inv=vbld_inv(j+nres)
13627 chi1=chi(itypi,itypj)
13628 chi2=chi(itypj,itypi)
13629 chi12=chi1*chi2
13630 chip1=chip(itypi)
13631       alf1=alp(itypi)
13632       alf2=alp(itypj)
13633       alf12=0.5D0*(alf1+alf2)
13634         xj=c(1,nres+j)-xi
13635         yj=c(2,nres+j)-yi
13636         zj=c(3,nres+j)-zi
13637             call to_box(xj,yj,zj)
13638             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13639             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13640              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13641             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13642              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13643             xj=boxshift(xj-xi,boxxsize)
13644             yj=boxshift(yj-yi,boxysize)
13645             zj=boxshift(zj-zi,boxzsize)
13646         dxj=dc_norm(1,nres+j)
13647         dyj=dc_norm(2,nres+j)
13648         dzj=dc_norm(3,nres+j)
13649         rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13650         rij=dsqrt(rrij)
13651       sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13652
13653         if (sss.lt.1.0d0) then
13654
13655         ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13656         call sc_angular
13657         ! Calculate whole angle-dependent part of epsilon and contributions
13658         ! to its derivatives
13659         fac=(rrij*sigsq)**expon2
13660         e1=fac*fac*aa_aq(itypi,itypj)
13661         e2=fac*bb_aq(itypi,itypj)
13662       evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13663         eps2der=evdwij*eps3rt
13664         eps3der=evdwij*eps2rt
13665         evdwij=evdwij*eps2rt*eps3rt
13666       evdw=evdw+evdwij*(1.0d0-sss)
13667         if (lprn) then
13668         sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13669       epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13670         !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13671         !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13672         !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13673         !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13674         !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13675         !d     &          evdwij
13676         endif
13677         ! Calculate gradient components.
13678         e1=e1*eps1*eps2rt**2*eps3rt**2
13679       fac=-expon*(e1+evdwij)
13680         sigder=fac/sigsq
13681         fac=rrij*fac
13682         ! Calculate radial part of the gradient
13683         gg(1)=xj*fac
13684         gg(2)=yj*fac
13685         gg(3)=zj*fac
13686         ! Calculate the angular part of the gradient and sum add the contributions
13687         ! to the appropriate components of the Cartesian gradient.
13688       call sc_grad_scale(1.0d0-sss)
13689         endif
13690         enddo      ! j
13691         enddo        ! iint
13692         enddo          ! i
13693         !     stop
13694         return
13695         end subroutine ebp_long
13696         !-----------------------------------------------------------------------------
13697       subroutine ebp_short(evdw)
13698         !
13699         ! This subroutine calculates the interaction energy of nonbonded side chains
13700         ! assuming the Berne-Pechukas potential of interaction.
13701         !
13702         use calc_data
13703 !      implicit real*8 (a-h,o-z)
13704         !      include 'DIMENSIONS'
13705         !      include 'COMMON.GEO'
13706         !      include 'COMMON.VAR'
13707         !      include 'COMMON.LOCAL'
13708         !      include 'COMMON.CHAIN'
13709         !      include 'COMMON.DERIV'
13710         !      include 'COMMON.NAMES'
13711         !      include 'COMMON.INTERACT'
13712         !      include 'COMMON.IOUNITS'
13713         !      include 'COMMON.CALC'
13714         use comm_srutu
13715         !el      integer :: icall
13716         !el      common /srutu/ icall
13717 !     double precision rrsave(maxdim)
13718         logical :: lprn
13719         !el local variables
13720         integer :: iint,itypi,itypi1,itypj
13721         real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
13722         real(kind=8) :: sss,e1,e2,evdw,aa,bb, &
13723         sslipi,ssgradlipi,sslipj,ssgradlipj
13724         evdw=0.0D0
13725         !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13726         evdw=0.0D0
13727         !     if (icall.eq.0) then
13728         !       lprn=.true.
13729         !     else
13730         lprn=.false.
13731         !     endif
13732         !el      ind=0
13733         do i=iatsc_s,iatsc_e
13734       itypi=itype(i,1)
13735         if (itypi.eq.ntyp1) cycle
13736         itypi1=itype(i+1,1)
13737         xi=c(1,nres+i)
13738         yi=c(2,nres+i)
13739         zi=c(3,nres+i)
13740         call to_box(xi,yi,zi)
13741       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13742
13743         dxi=dc_norm(1,nres+i)
13744         dyi=dc_norm(2,nres+i)
13745         dzi=dc_norm(3,nres+i)
13746         !        dsci_inv=dsc_inv(itypi)
13747       dsci_inv=vbld_inv(i+nres)
13748         !
13749         ! Calculate SC interaction energy.
13750         !
13751         do iint=1,nint_gr(i)
13752       do j=istart(i,iint),iend(i,iint)
13753         !el            ind=ind+1
13754       itypj=itype(j,1)
13755         if (itypj.eq.ntyp1) cycle
13756         !            dscj_inv=dsc_inv(itypj)
13757         dscj_inv=vbld_inv(j+nres)
13758         chi1=chi(itypi,itypj)
13759       chi2=chi(itypj,itypi)
13760         chi12=chi1*chi2
13761         chip1=chip(itypi)
13762       chip2=chip(itypj)
13763         chip12=chip1*chip2
13764         alf1=alp(itypi)
13765         alf2=alp(itypj)
13766       alf12=0.5D0*(alf1+alf2)
13767         xj=c(1,nres+j)-xi
13768         yj=c(2,nres+j)-yi
13769         zj=c(3,nres+j)-zi
13770         call to_box(xj,yj,zj)
13771       call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13772         aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13773         +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13774         bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13775              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13776             xj=boxshift(xj-xi,boxxsize)
13777             yj=boxshift(yj-yi,boxysize)
13778             zj=boxshift(zj-zi,boxzsize)
13779             dxj=dc_norm(1,nres+j)
13780             dyj=dc_norm(2,nres+j)
13781             dzj=dc_norm(3,nres+j)
13782             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13783             rij=dsqrt(rrij)
13784             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13785
13786             if (sss.gt.0.0d0) then
13787
13788 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13789               call sc_angular
13790 ! Calculate whole angle-dependent part of epsilon and contributions
13791 ! to its derivatives
13792               fac=(rrij*sigsq)**expon2
13793               e1=fac*fac*aa_aq(itypi,itypj)
13794               e2=fac*bb_aq(itypi,itypj)
13795               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13796               eps2der=evdwij*eps3rt
13797               eps3der=evdwij*eps2rt
13798               evdwij=evdwij*eps2rt*eps3rt
13799               evdw=evdw+evdwij*sss
13800               if (lprn) then
13801               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13802               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13803 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13804 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13805 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13806 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13807 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13808 !d     &          evdwij
13809               endif
13810 ! Calculate gradient components.
13811               e1=e1*eps1*eps2rt**2*eps3rt**2
13812               fac=-expon*(e1+evdwij)
13813               sigder=fac/sigsq
13814               fac=rrij*fac
13815 ! Calculate radial part of the gradient
13816               gg(1)=xj*fac
13817               gg(2)=yj*fac
13818               gg(3)=zj*fac
13819 ! Calculate the angular part of the gradient and sum add the contributions
13820 ! to the appropriate components of the Cartesian gradient.
13821               call sc_grad_scale(sss)
13822             endif
13823           enddo      ! j
13824         enddo        ! iint
13825       enddo          ! i
13826 !     stop
13827       return
13828       end subroutine ebp_short
13829 !-----------------------------------------------------------------------------
13830       subroutine egb_long(evdw)
13831 !
13832 ! This subroutine calculates the interaction energy of nonbonded side chains
13833 ! assuming the Gay-Berne potential of interaction.
13834 !
13835       use calc_data
13836 !      implicit real*8 (a-h,o-z)
13837 !      include 'DIMENSIONS'
13838 !      include 'COMMON.GEO'
13839 !      include 'COMMON.VAR'
13840 !      include 'COMMON.LOCAL'
13841 !      include 'COMMON.CHAIN'
13842 !      include 'COMMON.DERIV'
13843 !      include 'COMMON.NAMES'
13844 !      include 'COMMON.INTERACT'
13845 !      include 'COMMON.IOUNITS'
13846 !      include 'COMMON.CALC'
13847 !      include 'COMMON.CONTROL'
13848       logical :: lprn
13849 !el local variables
13850       integer :: iint,itypi,itypi1,itypj,subchap
13851       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13852       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13853       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13854                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13855                     ssgradlipi,ssgradlipj
13856
13857
13858       evdw=0.0D0
13859 !cccc      energy_dec=.false.
13860 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13861       evdw=0.0D0
13862       lprn=.false.
13863 !     if (icall.eq.0) lprn=.false.
13864 !el      ind=0
13865       do i=iatsc_s,iatsc_e
13866         itypi=itype(i,1)
13867         if (itypi.eq.ntyp1) cycle
13868         itypi1=itype(i+1,1)
13869         xi=c(1,nres+i)
13870         yi=c(2,nres+i)
13871         zi=c(3,nres+i)
13872         call to_box(xi,yi,zi)
13873         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13874         dxi=dc_norm(1,nres+i)
13875         dyi=dc_norm(2,nres+i)
13876         dzi=dc_norm(3,nres+i)
13877 !        dsci_inv=dsc_inv(itypi)
13878         dsci_inv=vbld_inv(i+nres)
13879 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13880 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13881 !
13882 ! Calculate SC interaction energy.
13883 !
13884         do iint=1,nint_gr(i)
13885           do j=istart(i,iint),iend(i,iint)
13886             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13887 !              call dyn_ssbond_ene(i,j,evdwij)
13888 !              evdw=evdw+evdwij
13889 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13890 !                              'evdw',i,j,evdwij,' ss'
13891 !              if (energy_dec) write (iout,*) &
13892 !                              'evdw',i,j,evdwij,' ss'
13893 !             do k=j+1,iend(i,iint)
13894 !C search over all next residues
13895 !              if (dyn_ss_mask(k)) then
13896 !C check if they are cysteins
13897 !C              write(iout,*) 'k=',k
13898
13899 !c              write(iout,*) "PRZED TRI", evdwij
13900 !               evdwij_przed_tri=evdwij
13901 !              call triple_ssbond_ene(i,j,k,evdwij)
13902 !c               if(evdwij_przed_tri.ne.evdwij) then
13903 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13904 !c               endif
13905
13906 !c              write(iout,*) "PO TRI", evdwij
13907 !C call the energy function that removes the artifical triple disulfide
13908 !C bond the soubroutine is located in ssMD.F
13909 !              evdw=evdw+evdwij
13910               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13911                             'evdw',i,j,evdwij,'tss'
13912 !              endif!dyn_ss_mask(k)
13913 !             enddo! k
13914
13915             ELSE
13916 !el            ind=ind+1
13917             itypj=itype(j,1)
13918             if (itypj.eq.ntyp1) cycle
13919 !            dscj_inv=dsc_inv(itypj)
13920             dscj_inv=vbld_inv(j+nres)
13921 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13922 !     &       1.0d0/vbld(j+nres)
13923 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13924             sig0ij=sigma(itypi,itypj)
13925             chi1=chi(itypi,itypj)
13926             chi2=chi(itypj,itypi)
13927             chi12=chi1*chi2
13928             chip1=chip(itypi)
13929             chip2=chip(itypj)
13930             chip12=chip1*chip2
13931             alf1=alp(itypi)
13932             alf2=alp(itypj)
13933             alf12=0.5D0*(alf1+alf2)
13934             xj=c(1,nres+j)
13935             yj=c(2,nres+j)
13936             zj=c(3,nres+j)
13937 ! Searching for nearest neighbour
13938             call to_box(xj,yj,zj)
13939             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13940             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13941              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13942             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13943              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13944             xj=boxshift(xj-xi,boxxsize)
13945             yj=boxshift(yj-yi,boxysize)
13946             zj=boxshift(zj-zi,boxzsize)
13947             dxj=dc_norm(1,nres+j)
13948             dyj=dc_norm(2,nres+j)
13949             dzj=dc_norm(3,nres+j)
13950             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13951             rij=dsqrt(rrij)
13952             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13953             sss_ele_cut=sscale_ele(1.0d0/(rij))
13954             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
13955             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13956             if (sss_ele_cut.le.0.0) cycle
13957             if (sss.lt.1.0d0) then
13958
13959 ! Calculate angle-dependent terms of energy and contributions to their
13960 ! derivatives.
13961               call sc_angular
13962               sigsq=1.0D0/sigsq
13963               sig=sig0ij*dsqrt(sigsq)
13964               rij_shift=1.0D0/rij-sig+sig0ij
13965 ! for diagnostics; uncomment
13966 !              rij_shift=1.2*sig0ij
13967 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13968               if (rij_shift.le.0.0D0) then
13969                 evdw=1.0D20
13970 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13971 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13972 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13973                 return
13974               endif
13975               sigder=-sig*sigsq
13976 !---------------------------------------------------------------
13977               rij_shift=1.0D0/rij_shift
13978               fac=rij_shift**expon
13979               e1=fac*fac*aa
13980               e2=fac*bb
13981               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13982               eps2der=evdwij*eps3rt
13983               eps3der=evdwij*eps2rt
13984 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13985 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13986               evdwij=evdwij*eps2rt*eps3rt
13987               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
13988               if (lprn) then
13989               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13990               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13991               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13992                 restyp(itypi,1),i,restyp(itypj,1),j,&
13993                 epsi,sigm,chi1,chi2,chip1,chip2,&
13994                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13995                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13996                 evdwij
13997               endif
13998
13999               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14000                               'evdw',i,j,evdwij
14001 !              if (energy_dec) write (iout,*) &
14002 !                              'evdw',i,j,evdwij,"egb_long"
14003
14004 ! Calculate gradient components.
14005               e1=e1*eps1*eps2rt**2*eps3rt**2
14006               fac=-expon*(e1+evdwij)*rij_shift
14007               sigder=fac*sigder
14008               fac=rij*fac
14009               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14010               *rij-sss_grad/(1.0-sss)*rij  &
14011             /sigmaii(itypi,itypj))
14012 !              fac=0.0d0
14013 ! Calculate the radial part of the gradient
14014               gg(1)=xj*fac
14015               gg(2)=yj*fac
14016               gg(3)=zj*fac
14017 ! Calculate angular part of the gradient.
14018               call sc_grad_scale(1.0d0-sss)
14019             ENDIF    !mask_dyn_ss
14020             endif
14021           enddo      ! j
14022         enddo        ! iint
14023       enddo          ! i
14024 !      write (iout,*) "Number of loop steps in EGB:",ind
14025 !ccc      energy_dec=.false.
14026       return
14027       end subroutine egb_long
14028 !-----------------------------------------------------------------------------
14029       subroutine egb_short(evdw)
14030 !
14031 ! This subroutine calculates the interaction energy of nonbonded side chains
14032 ! assuming the Gay-Berne potential of interaction.
14033 !
14034       use calc_data
14035 !      implicit real*8 (a-h,o-z)
14036 !      include 'DIMENSIONS'
14037 !      include 'COMMON.GEO'
14038 !      include 'COMMON.VAR'
14039 !      include 'COMMON.LOCAL'
14040 !      include 'COMMON.CHAIN'
14041 !      include 'COMMON.DERIV'
14042 !      include 'COMMON.NAMES'
14043 !      include 'COMMON.INTERACT'
14044 !      include 'COMMON.IOUNITS'
14045 !      include 'COMMON.CALC'
14046 !      include 'COMMON.CONTROL'
14047       logical :: lprn
14048 !el local variables
14049       integer :: iint,itypi,itypi1,itypj,subchap
14050       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
14051       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
14052       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14053                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
14054                     ssgradlipi,ssgradlipj
14055       evdw=0.0D0
14056 !cccc      energy_dec=.false.
14057 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14058       evdw=0.0D0
14059       lprn=.false.
14060 !     if (icall.eq.0) lprn=.false.
14061 !el      ind=0
14062       do i=iatsc_s,iatsc_e
14063         itypi=itype(i,1)
14064         if (itypi.eq.ntyp1) cycle
14065         itypi1=itype(i+1,1)
14066         xi=c(1,nres+i)
14067         yi=c(2,nres+i)
14068         zi=c(3,nres+i)
14069         call to_box(xi,yi,zi)
14070         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14071
14072         dxi=dc_norm(1,nres+i)
14073         dyi=dc_norm(2,nres+i)
14074         dzi=dc_norm(3,nres+i)
14075 !        dsci_inv=dsc_inv(itypi)
14076         dsci_inv=vbld_inv(i+nres)
14077
14078         dxi=dc_norm(1,nres+i)
14079         dyi=dc_norm(2,nres+i)
14080         dzi=dc_norm(3,nres+i)
14081 !        dsci_inv=dsc_inv(itypi)
14082         dsci_inv=vbld_inv(i+nres)
14083         do iint=1,nint_gr(i)
14084           do j=istart(i,iint),iend(i,iint)
14085             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
14086               call dyn_ssbond_ene(i,j,evdwij)
14087               evdw=evdw+evdwij
14088               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14089                               'evdw',i,j,evdwij,' ss'
14090              do k=j+1,iend(i,iint)
14091 !C search over all next residues
14092               if (dyn_ss_mask(k)) then
14093 !C check if they are cysteins
14094 !C              write(iout,*) 'k=',k
14095
14096 !c              write(iout,*) "PRZED TRI", evdwij
14097 !               evdwij_przed_tri=evdwij
14098               call triple_ssbond_ene(i,j,k,evdwij)
14099 !c               if(evdwij_przed_tri.ne.evdwij) then
14100 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
14101 !c               endif
14102
14103 !c              write(iout,*) "PO TRI", evdwij
14104 !C call the energy function that removes the artifical triple disulfide
14105 !C bond the soubroutine is located in ssMD.F
14106               evdw=evdw+evdwij
14107               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14108                             'evdw',i,j,evdwij,'tss'
14109               endif!dyn_ss_mask(k)
14110              enddo! k
14111             ELSE
14112
14113 !          typj=itype(j,1)
14114             if (itypj.eq.ntyp1) cycle
14115 !            dscj_inv=dsc_inv(itypj)
14116             dscj_inv=vbld_inv(j+nres)
14117             dscj_inv=dsc_inv(itypj)
14118 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
14119 !     &       1.0d0/vbld(j+nres)
14120 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
14121             sig0ij=sigma(itypi,itypj)
14122             chi1=chi(itypi,itypj)
14123             chi2=chi(itypj,itypi)
14124             chi12=chi1*chi2
14125             chip1=chip(itypi)
14126             chip2=chip(itypj)
14127             chip12=chip1*chip2
14128             alf1=alp(itypi)
14129             alf2=alp(itypj)
14130             alf12=0.5D0*(alf1+alf2)
14131 !            xj=c(1,nres+j)-xi
14132 !            yj=c(2,nres+j)-yi
14133 !            zj=c(3,nres+j)-zi
14134             xj=c(1,nres+j)
14135             yj=c(2,nres+j)
14136             zj=c(3,nres+j)
14137 ! Searching for nearest neighbour
14138             call to_box(xj,yj,zj)
14139             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14140             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14141              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14142             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14143              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14144             xj=boxshift(xj-xi,boxxsize)
14145             yj=boxshift(yj-yi,boxysize)
14146             zj=boxshift(zj-zi,boxzsize)
14147             dxj=dc_norm(1,nres+j)
14148             dyj=dc_norm(2,nres+j)
14149             dzj=dc_norm(3,nres+j)
14150             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14151             rij=dsqrt(rrij)
14152             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14153             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14154             sss_ele_cut=sscale_ele(1.0d0/(rij))
14155             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
14156             if (sss_ele_cut.le.0.0) cycle
14157
14158             if (sss.gt.0.0d0) then
14159
14160 ! Calculate angle-dependent terms of energy and contributions to their
14161 ! derivatives.
14162               call sc_angular
14163               sigsq=1.0D0/sigsq
14164               sig=sig0ij*dsqrt(sigsq)
14165               rij_shift=1.0D0/rij-sig+sig0ij
14166 ! for diagnostics; uncomment
14167 !              rij_shift=1.2*sig0ij
14168 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14169               if (rij_shift.le.0.0D0) then
14170                 evdw=1.0D20
14171 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14172 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14173 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14174                 return
14175               endif
14176               sigder=-sig*sigsq
14177 !---------------------------------------------------------------
14178               rij_shift=1.0D0/rij_shift
14179               fac=rij_shift**expon
14180               e1=fac*fac*aa
14181               e2=fac*bb
14182               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14183               eps2der=evdwij*eps3rt
14184               eps3der=evdwij*eps2rt
14185 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14186 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14187               evdwij=evdwij*eps2rt*eps3rt
14188               evdw=evdw+evdwij*sss*sss_ele_cut
14189               if (lprn) then
14190               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14191               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14192               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14193                 restyp(itypi,1),i,restyp(itypj,1),j,&
14194                 epsi,sigm,chi1,chi2,chip1,chip2,&
14195                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14196                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14197                 evdwij
14198               endif
14199
14200               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14201                               'evdw',i,j,evdwij
14202 !              if (energy_dec) write (iout,*) &
14203 !                              'evdw',i,j,evdwij,"egb_short"
14204
14205 ! Calculate gradient components.
14206               e1=e1*eps1*eps2rt**2*eps3rt**2
14207               fac=-expon*(e1+evdwij)*rij_shift
14208               sigder=fac*sigder
14209               fac=rij*fac
14210               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14211             *rij+sss_grad/sss*rij  &
14212             /sigmaii(itypi,itypj))
14213
14214 !              fac=0.0d0
14215 ! Calculate the radial part of the gradient
14216               gg(1)=xj*fac
14217               gg(2)=yj*fac
14218               gg(3)=zj*fac
14219 ! Calculate angular part of the gradient.
14220               call sc_grad_scale(sss)
14221             endif
14222           ENDIF !mask_dyn_ss
14223           enddo      ! j
14224         enddo        ! iint
14225       enddo          ! i
14226 !      write (iout,*) "Number of loop steps in EGB:",ind
14227 !ccc      energy_dec=.false.
14228       return
14229       end subroutine egb_short
14230 !-----------------------------------------------------------------------------
14231       subroutine egbv_long(evdw)
14232 !
14233 ! This subroutine calculates the interaction energy of nonbonded side chains
14234 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14235 !
14236       use calc_data
14237 !      implicit real*8 (a-h,o-z)
14238 !      include 'DIMENSIONS'
14239 !      include 'COMMON.GEO'
14240 !      include 'COMMON.VAR'
14241 !      include 'COMMON.LOCAL'
14242 !      include 'COMMON.CHAIN'
14243 !      include 'COMMON.DERIV'
14244 !      include 'COMMON.NAMES'
14245 !      include 'COMMON.INTERACT'
14246 !      include 'COMMON.IOUNITS'
14247 !      include 'COMMON.CALC'
14248       use comm_srutu
14249 !el      integer :: icall
14250 !el      common /srutu/ icall
14251       logical :: lprn
14252 !el local variables
14253       integer :: iint,itypi,itypi1,itypj
14254       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij,&
14255                       sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
14256       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
14257       evdw=0.0D0
14258 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14259       evdw=0.0D0
14260       lprn=.false.
14261 !     if (icall.eq.0) lprn=.true.
14262 !el      ind=0
14263       do i=iatsc_s,iatsc_e
14264         itypi=itype(i,1)
14265         if (itypi.eq.ntyp1) cycle
14266         itypi1=itype(i+1,1)
14267         xi=c(1,nres+i)
14268         yi=c(2,nres+i)
14269         zi=c(3,nres+i)
14270         call to_box(xi,yi,zi)
14271         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14272         dxi=dc_norm(1,nres+i)
14273         dyi=dc_norm(2,nres+i)
14274         dzi=dc_norm(3,nres+i)
14275
14276 !        dsci_inv=dsc_inv(itypi)
14277         dsci_inv=vbld_inv(i+nres)
14278 !
14279 ! Calculate SC interaction energy.
14280 !
14281         do iint=1,nint_gr(i)
14282           do j=istart(i,iint),iend(i,iint)
14283 !el            ind=ind+1
14284             itypj=itype(j,1)
14285             if (itypj.eq.ntyp1) cycle
14286 !            dscj_inv=dsc_inv(itypj)
14287             dscj_inv=vbld_inv(j+nres)
14288             sig0ij=sigma(itypi,itypj)
14289             r0ij=r0(itypi,itypj)
14290             chi1=chi(itypi,itypj)
14291             chi2=chi(itypj,itypi)
14292             chi12=chi1*chi2
14293             chip1=chip(itypi)
14294             chip2=chip(itypj)
14295             chip12=chip1*chip2
14296             alf1=alp(itypi)
14297             alf2=alp(itypj)
14298             alf12=0.5D0*(alf1+alf2)
14299             xj=c(1,nres+j)-xi
14300             yj=c(2,nres+j)-yi
14301             zj=c(3,nres+j)-zi
14302             call to_box(xj,yj,zj)
14303             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14304             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14305             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14306             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14307             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14308             xj=boxshift(xj-xi,boxxsize)
14309             yj=boxshift(yj-yi,boxysize)
14310             zj=boxshift(zj-zi,boxzsize)
14311             dxj=dc_norm(1,nres+j)
14312             dyj=dc_norm(2,nres+j)
14313             dzj=dc_norm(3,nres+j)
14314             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14315             rij=dsqrt(rrij)
14316
14317             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14318
14319             if (sss.lt.1.0d0) then
14320
14321 ! Calculate angle-dependent terms of energy and contributions to their
14322 ! derivatives.
14323               call sc_angular
14324               sigsq=1.0D0/sigsq
14325               sig=sig0ij*dsqrt(sigsq)
14326               rij_shift=1.0D0/rij-sig+r0ij
14327 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14328               if (rij_shift.le.0.0D0) then
14329                 evdw=1.0D20
14330                 return
14331               endif
14332               sigder=-sig*sigsq
14333 !---------------------------------------------------------------
14334               rij_shift=1.0D0/rij_shift
14335               fac=rij_shift**expon
14336               e1=fac*fac*aa_aq(itypi,itypj)
14337               e2=fac*bb_aq(itypi,itypj)
14338               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14339               eps2der=evdwij*eps3rt
14340               eps3der=evdwij*eps2rt
14341               fac_augm=rrij**expon
14342               e_augm=augm(itypi,itypj)*fac_augm
14343               evdwij=evdwij*eps2rt*eps3rt
14344               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
14345               if (lprn) then
14346               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14347               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14348               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14349                 restyp(itypi,1),i,restyp(itypj,1),j,&
14350                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14351                 chi1,chi2,chip1,chip2,&
14352                 eps1,eps2rt**2,eps3rt**2,&
14353                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14354                 evdwij+e_augm
14355               endif
14356 ! Calculate gradient components.
14357               e1=e1*eps1*eps2rt**2*eps3rt**2
14358               fac=-expon*(e1+evdwij)*rij_shift
14359               sigder=fac*sigder
14360               fac=rij*fac-2*expon*rrij*e_augm
14361 ! Calculate the radial part of the gradient
14362               gg(1)=xj*fac
14363               gg(2)=yj*fac
14364               gg(3)=zj*fac
14365 ! Calculate angular part of the gradient.
14366               call sc_grad_scale(1.0d0-sss)
14367             endif
14368           enddo      ! j
14369         enddo        ! iint
14370       enddo          ! i
14371       end subroutine egbv_long
14372 !-----------------------------------------------------------------------------
14373       subroutine egbv_short(evdw)
14374 !
14375 ! This subroutine calculates the interaction energy of nonbonded side chains
14376 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14377 !
14378       use calc_data
14379 !      implicit real*8 (a-h,o-z)
14380 !      include 'DIMENSIONS'
14381 !      include 'COMMON.GEO'
14382 !      include 'COMMON.VAR'
14383 !      include 'COMMON.LOCAL'
14384 !      include 'COMMON.CHAIN'
14385 !      include 'COMMON.DERIV'
14386 !      include 'COMMON.NAMES'
14387 !      include 'COMMON.INTERACT'
14388 !      include 'COMMON.IOUNITS'
14389 !      include 'COMMON.CALC'
14390       use comm_srutu
14391 !el      integer :: icall
14392 !el      common /srutu/ icall
14393       logical :: lprn
14394 !el local variables
14395       integer :: iint,itypi,itypi1,itypj
14396       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift,&
14397                       sslipi,ssgradlipi, sslipj,ssgradlipj,aa,bb
14398       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
14399       evdw=0.0D0
14400 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14401       evdw=0.0D0
14402       lprn=.false.
14403 !     if (icall.eq.0) lprn=.true.
14404 !el      ind=0
14405       do i=iatsc_s,iatsc_e
14406         itypi=itype(i,1)
14407         if (itypi.eq.ntyp1) cycle
14408         itypi1=itype(i+1,1)
14409         xi=c(1,nres+i)
14410         yi=c(2,nres+i)
14411         zi=c(3,nres+i)
14412         dxi=dc_norm(1,nres+i)
14413         dyi=dc_norm(2,nres+i)
14414         dzi=dc_norm(3,nres+i)
14415         call to_box(xi,yi,zi)
14416         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14417 !        dsci_inv=dsc_inv(itypi)
14418         dsci_inv=vbld_inv(i+nres)
14419 !
14420 ! Calculate SC interaction energy.
14421 !
14422         do iint=1,nint_gr(i)
14423           do j=istart(i,iint),iend(i,iint)
14424 !el            ind=ind+1
14425             itypj=itype(j,1)
14426             if (itypj.eq.ntyp1) cycle
14427 !            dscj_inv=dsc_inv(itypj)
14428             dscj_inv=vbld_inv(j+nres)
14429             sig0ij=sigma(itypi,itypj)
14430             r0ij=r0(itypi,itypj)
14431             chi1=chi(itypi,itypj)
14432             chi2=chi(itypj,itypi)
14433             chi12=chi1*chi2
14434             chip1=chip(itypi)
14435             chip2=chip(itypj)
14436             chip12=chip1*chip2
14437             alf1=alp(itypi)
14438             alf2=alp(itypj)
14439             alf12=0.5D0*(alf1+alf2)
14440             xj=c(1,nres+j)-xi
14441             yj=c(2,nres+j)-yi
14442             zj=c(3,nres+j)-zi
14443             call to_box(xj,yj,zj)
14444             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14445             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14446             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14447             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14448             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14449             xj=boxshift(xj-xi,boxxsize)
14450             yj=boxshift(yj-yi,boxysize)
14451             zj=boxshift(zj-zi,boxzsize)
14452             dxj=dc_norm(1,nres+j)
14453             dyj=dc_norm(2,nres+j)
14454             dzj=dc_norm(3,nres+j)
14455             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14456             rij=dsqrt(rrij)
14457
14458             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14459
14460             if (sss.gt.0.0d0) then
14461
14462 ! Calculate angle-dependent terms of energy and contributions to their
14463 ! derivatives.
14464               call sc_angular
14465               sigsq=1.0D0/sigsq
14466               sig=sig0ij*dsqrt(sigsq)
14467               rij_shift=1.0D0/rij-sig+r0ij
14468 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14469               if (rij_shift.le.0.0D0) then
14470                 evdw=1.0D20
14471                 return
14472               endif
14473               sigder=-sig*sigsq
14474 !---------------------------------------------------------------
14475               rij_shift=1.0D0/rij_shift
14476               fac=rij_shift**expon
14477               e1=fac*fac*aa_aq(itypi,itypj)
14478               e2=fac*bb_aq(itypi,itypj)
14479               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14480               eps2der=evdwij*eps3rt
14481               eps3der=evdwij*eps2rt
14482               fac_augm=rrij**expon
14483               e_augm=augm(itypi,itypj)*fac_augm
14484               evdwij=evdwij*eps2rt*eps3rt
14485               evdw=evdw+(evdwij+e_augm)*sss
14486               if (lprn) then
14487               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14488               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14489               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14490                 restyp(itypi,1),i,restyp(itypj,1),j,&
14491                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14492                 chi1,chi2,chip1,chip2,&
14493                 eps1,eps2rt**2,eps3rt**2,&
14494                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14495                 evdwij+e_augm
14496               endif
14497 ! Calculate gradient components.
14498               e1=e1*eps1*eps2rt**2*eps3rt**2
14499               fac=-expon*(e1+evdwij)*rij_shift
14500               sigder=fac*sigder
14501               fac=rij*fac-2*expon*rrij*e_augm
14502 ! Calculate the radial part of the gradient
14503               gg(1)=xj*fac
14504               gg(2)=yj*fac
14505               gg(3)=zj*fac
14506 ! Calculate angular part of the gradient.
14507               call sc_grad_scale(sss)
14508             endif
14509           enddo      ! j
14510         enddo        ! iint
14511       enddo          ! i
14512       end subroutine egbv_short
14513 !-----------------------------------------------------------------------------
14514       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
14515 !
14516 ! This subroutine calculates the average interaction energy and its gradient
14517 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
14518 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
14519 ! The potential depends both on the distance of peptide-group centers and on
14520 ! the orientation of the CA-CA virtual bonds.
14521 !
14522 !      implicit real*8 (a-h,o-z)
14523
14524       use comm_locel
14525 #ifdef MPI
14526       include 'mpif.h'
14527 #endif
14528 !      include 'DIMENSIONS'
14529 !      include 'COMMON.CONTROL'
14530 !      include 'COMMON.SETUP'
14531 !      include 'COMMON.IOUNITS'
14532 !      include 'COMMON.GEO'
14533 !      include 'COMMON.VAR'
14534 !      include 'COMMON.LOCAL'
14535 !      include 'COMMON.CHAIN'
14536 !      include 'COMMON.DERIV'
14537 !      include 'COMMON.INTERACT'
14538 !      include 'COMMON.CONTACTS'
14539 !      include 'COMMON.TORSION'
14540 !      include 'COMMON.VECTORS'
14541 !      include 'COMMON.FFIELD'
14542 !      include 'COMMON.TIME1'
14543       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
14544       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
14545       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14546 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14547       real(kind=8),dimension(4) :: muij
14548 !el      integer :: num_conti,j1,j2
14549 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14550 !el                   dz_normi,xmedi,ymedi,zmedi
14551 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14552 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14553 !el          num_conti,j1,j2
14554 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14555 #ifdef MOMENT
14556       real(kind=8) :: scal_el=1.0d0
14557 #else
14558       real(kind=8) :: scal_el=0.5d0
14559 #endif
14560 ! 12/13/98
14561 ! 13-go grudnia roku pamietnego...
14562       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14563                                              0.0d0,1.0d0,0.0d0,&
14564                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14565 !el local variables
14566       integer :: i,j,k
14567       real(kind=8) :: fac
14568       real(kind=8) :: dxj,dyj,dzj
14569       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
14570
14571 !      allocate(num_cont_hb(nres)) !(maxres)
14572 !d      write(iout,*) 'In EELEC'
14573 !d      do i=1,nloctyp
14574 !d        write(iout,*) 'Type',i
14575 !d        write(iout,*) 'B1',B1(:,i)
14576 !d        write(iout,*) 'B2',B2(:,i)
14577 !d        write(iout,*) 'CC',CC(:,:,i)
14578 !d        write(iout,*) 'DD',DD(:,:,i)
14579 !d        write(iout,*) 'EE',EE(:,:,i)
14580 !d      enddo
14581 !d      call check_vecgrad
14582 !d      stop
14583       if (icheckgrad.eq.1) then
14584         do i=1,nres-1
14585           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
14586           do k=1,3
14587             dc_norm(k,i)=dc(k,i)*fac
14588           enddo
14589 !          write (iout,*) 'i',i,' fac',fac
14590         enddo
14591       endif
14592       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14593           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
14594           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
14595 !        call vec_and_deriv
14596 #ifdef TIMING
14597         time01=MPI_Wtime()
14598 #endif
14599 !        print *, "before set matrices"
14600         call set_matrices
14601 !        print *,"after set martices"
14602 #ifdef TIMING
14603         time_mat=time_mat+MPI_Wtime()-time01
14604 #endif
14605       endif
14606 !d      do i=1,nres-1
14607 !d        write (iout,*) 'i=',i
14608 !d        do k=1,3
14609 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
14610 !d        enddo
14611 !d        do k=1,3
14612 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
14613 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
14614 !d        enddo
14615 !d      enddo
14616       t_eelecij=0.0d0
14617       ees=0.0D0
14618       evdw1=0.0D0
14619       eel_loc=0.0d0
14620       eello_turn3=0.0d0
14621       eello_turn4=0.0d0
14622 !el      ind=0
14623       do i=1,nres
14624         num_cont_hb(i)=0
14625       enddo
14626 !d      print '(a)','Enter EELEC'
14627 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
14628 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14629 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14630       do i=1,nres
14631         gel_loc_loc(i)=0.0d0
14632         gcorr_loc(i)=0.0d0
14633       enddo
14634 !
14635 !
14636 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
14637 !
14638 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
14639 !
14640       do i=iturn3_start,iturn3_end
14641         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
14642         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,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         call to_box(xmedi,ymedi,zmedi)
14653         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
14654         num_conti=0
14655         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
14656         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
14657         num_cont_hb(i)=num_conti
14658       enddo
14659       do i=iturn4_start,iturn4_end
14660         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
14661           .or. itype(i+3,1).eq.ntyp1 &
14662           .or. itype(i+4,1).eq.ntyp1) cycle
14663         dxi=dc(1,i)
14664         dyi=dc(2,i)
14665         dzi=dc(3,i)
14666         dx_normi=dc_norm(1,i)
14667         dy_normi=dc_norm(2,i)
14668         dz_normi=dc_norm(3,i)
14669         xmedi=c(1,i)+0.5d0*dxi
14670         ymedi=c(2,i)+0.5d0*dyi
14671         zmedi=c(3,i)+0.5d0*dzi
14672
14673         call to_box(xmedi,ymedi,zmedi)
14674         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
14675
14676         num_conti=num_cont_hb(i)
14677         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
14678         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
14679           call eturn4(i,eello_turn4)
14680         num_cont_hb(i)=num_conti
14681       enddo   ! i
14682 !
14683 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
14684 !
14685       do i=iatel_s,iatel_e
14686         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14687         dxi=dc(1,i)
14688         dyi=dc(2,i)
14689         dzi=dc(3,i)
14690         dx_normi=dc_norm(1,i)
14691         dy_normi=dc_norm(2,i)
14692         dz_normi=dc_norm(3,i)
14693         xmedi=c(1,i)+0.5d0*dxi
14694         ymedi=c(2,i)+0.5d0*dyi
14695         zmedi=c(3,i)+0.5d0*dzi
14696         call to_box(xmedi,ymedi,zmedi)
14697         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
14698 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14699         num_conti=num_cont_hb(i)
14700         do j=ielstart(i),ielend(i)
14701           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14702           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14703         enddo ! j
14704         num_cont_hb(i)=num_conti
14705       enddo   ! i
14706 !      write (iout,*) "Number of loop steps in EELEC:",ind
14707 !d      do i=1,nres
14708 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14709 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14710 !d      enddo
14711 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14712 !cc      eel_loc=eel_loc+eello_turn3
14713 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14714       return
14715       end subroutine eelec_scale
14716 !-----------------------------------------------------------------------------
14717       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14718 !      implicit real*8 (a-h,o-z)
14719
14720       use comm_locel
14721 !      include 'DIMENSIONS'
14722 #ifdef MPI
14723       include "mpif.h"
14724 #endif
14725 !      include 'COMMON.CONTROL'
14726 !      include 'COMMON.IOUNITS'
14727 !      include 'COMMON.GEO'
14728 !      include 'COMMON.VAR'
14729 !      include 'COMMON.LOCAL'
14730 !      include 'COMMON.CHAIN'
14731 !      include 'COMMON.DERIV'
14732 !      include 'COMMON.INTERACT'
14733 !      include 'COMMON.CONTACTS'
14734 !      include 'COMMON.TORSION'
14735 !      include 'COMMON.VECTORS'
14736 !      include 'COMMON.FFIELD'
14737 !      include 'COMMON.TIME1'
14738       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14739       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14740       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14741 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14742       real(kind=8),dimension(4) :: muij
14743       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14744                     dist_temp, dist_init,sss_grad
14745       integer xshift,yshift,zshift
14746
14747 !el      integer :: num_conti,j1,j2
14748 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14749 !el                   dz_normi,xmedi,ymedi,zmedi
14750 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14751 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14752 !el          num_conti,j1,j2
14753 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14754 #ifdef MOMENT
14755       real(kind=8) :: scal_el=1.0d0
14756 #else
14757       real(kind=8) :: scal_el=0.5d0
14758 #endif
14759 ! 12/13/98
14760 ! 13-go grudnia roku pamietnego...
14761       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14762                                              0.0d0,1.0d0,0.0d0,&
14763                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14764 !el local variables
14765       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
14766       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
14767       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
14768       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
14769       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
14770       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
14771       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
14772                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
14773                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
14774                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
14775                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
14776                   ecosam,ecosbm,ecosgm,ghalf,time00,faclipij,faclipij2
14777 !      integer :: maxconts
14778 !      maxconts = nres/4
14779 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14780 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14781 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14782 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14783 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14784 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14785 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14786 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14787 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
14788 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
14789 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
14790 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
14791 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
14792
14793 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
14794 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
14795
14796 #ifdef MPI
14797           time00=MPI_Wtime()
14798 #endif
14799 !d      write (iout,*) "eelecij",i,j
14800 !el          ind=ind+1
14801           iteli=itel(i)
14802           itelj=itel(j)
14803           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14804           aaa=app(iteli,itelj)
14805           bbb=bpp(iteli,itelj)
14806           ael6i=ael6(iteli,itelj)
14807           ael3i=ael3(iteli,itelj)
14808           dxj=dc(1,j)
14809           dyj=dc(2,j)
14810           dzj=dc(3,j)
14811           dx_normj=dc_norm(1,j)
14812           dy_normj=dc_norm(2,j)
14813           dz_normj=dc_norm(3,j)
14814 !          xj=c(1,j)+0.5D0*dxj-xmedi
14815 !          yj=c(2,j)+0.5D0*dyj-ymedi
14816 !          zj=c(3,j)+0.5D0*dzj-zmedi
14817           xj=c(1,j)+0.5D0*dxj
14818           yj=c(2,j)+0.5D0*dyj
14819           zj=c(3,j)+0.5D0*dzj
14820           call to_box(xj,yj,zj)
14821           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14822           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
14823           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
14824           xj=boxshift(xj-xmedi,boxxsize)
14825           yj=boxshift(yj-ymedi,boxysize)
14826           zj=boxshift(zj-zmedi,boxzsize)
14827           rij=xj*xj+yj*yj+zj*zj
14828           rrmij=1.0D0/rij
14829           rij=dsqrt(rij)
14830           rmij=1.0D0/rij
14831 ! For extracting the short-range part of Evdwpp
14832           sss=sscale(rij/rpp(iteli,itelj))
14833             sss_ele_cut=sscale_ele(rij)
14834             sss_ele_grad=sscagrad_ele(rij)
14835             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14836 !             sss_ele_cut=1.0d0
14837 !             sss_ele_grad=0.0d0
14838             if (sss_ele_cut.le.0.0) go to 128
14839
14840           r3ij=rrmij*rmij
14841           r6ij=r3ij*r3ij
14842           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
14843           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
14844           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
14845           fac=cosa-3.0D0*cosb*cosg
14846           ev1=aaa*r6ij*r6ij
14847 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14848           if (j.eq.i+2) ev1=scal_el*ev1
14849           ev2=bbb*r6ij
14850           fac3=ael6i*r6ij
14851           fac4=ael3i*r3ij
14852           evdwij=ev1+ev2
14853           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
14854           el2=fac4*fac
14855           eesij=el1+el2
14856 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
14857           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
14858           ees=ees+eesij*sss_ele_cut
14859           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
14860 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
14861 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
14862 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
14863 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
14864
14865           if (energy_dec) then
14866               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14867               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
14868           endif
14869
14870 !
14871 ! Calculate contributions to the Cartesian gradient.
14872 !
14873 #ifdef SPLITELE
14874           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14875           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
14876           fac1=fac
14877           erij(1)=xj*rmij
14878           erij(2)=yj*rmij
14879           erij(3)=zj*rmij
14880 !
14881 ! Radial derivatives. First process both termini of the fragment (i,j)
14882 !
14883           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
14884           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
14885           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
14886 !          do k=1,3
14887 !            ghalf=0.5D0*ggg(k)
14888 !            gelc(k,i)=gelc(k,i)+ghalf
14889 !            gelc(k,j)=gelc(k,j)+ghalf
14890 !          enddo
14891 ! 9/28/08 AL Gradient compotents will be summed only at the end
14892           do k=1,3
14893             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14894             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14895           enddo
14896 !
14897 ! Loop over residues i+1 thru j-1.
14898 !
14899 !grad          do k=i+1,j-1
14900 !grad            do l=1,3
14901 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14902 !grad            enddo
14903 !grad          enddo
14904           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
14905           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14906           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
14907           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14908           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
14909           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14910 !          do k=1,3
14911 !            ghalf=0.5D0*ggg(k)
14912 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
14913 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
14914 !          enddo
14915 ! 9/28/08 AL Gradient compotents will be summed only at the end
14916           do k=1,3
14917             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14918             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14919           enddo
14920 !
14921 ! Loop over residues i+1 thru j-1.
14922 !
14923 !grad          do k=i+1,j-1
14924 !grad            do l=1,3
14925 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
14926 !grad            enddo
14927 !grad          enddo
14928 #else
14929           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14930           facel=(el1+eesij)*sss_ele_cut
14931           fac1=fac
14932           fac=-3*rrmij*(facvdw+facvdw+facel)
14933           erij(1)=xj*rmij
14934           erij(2)=yj*rmij
14935           erij(3)=zj*rmij
14936 !
14937 ! Radial derivatives. First process both termini of the fragment (i,j)
14938 !
14939           ggg(1)=fac*xj
14940           ggg(2)=fac*yj
14941           ggg(3)=fac*zj
14942 !          do k=1,3
14943 !            ghalf=0.5D0*ggg(k)
14944 !            gelc(k,i)=gelc(k,i)+ghalf
14945 !            gelc(k,j)=gelc(k,j)+ghalf
14946 !          enddo
14947 ! 9/28/08 AL Gradient compotents will be summed only at the end
14948           do k=1,3
14949             gelc_long(k,j)=gelc(k,j)+ggg(k)
14950             gelc_long(k,i)=gelc(k,i)-ggg(k)
14951           enddo
14952 !
14953 ! Loop over residues i+1 thru j-1.
14954 !
14955 !grad          do k=i+1,j-1
14956 !grad            do l=1,3
14957 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14958 !grad            enddo
14959 !grad          enddo
14960 ! 9/28/08 AL Gradient compotents will be summed only at the end
14961           ggg(1)=facvdw*xj
14962           ggg(2)=facvdw*yj
14963           ggg(3)=facvdw*zj
14964           do k=1,3
14965             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14966             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14967           enddo
14968 #endif
14969 !
14970 ! Angular part
14971 !
14972           ecosa=2.0D0*fac3*fac1+fac4
14973           fac4=-3.0D0*fac4
14974           fac3=-6.0D0*fac3
14975           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
14976           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
14977           do k=1,3
14978             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14979             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14980           enddo
14981 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
14982 !d   &          (dcosg(k),k=1,3)
14983           do k=1,3
14984             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
14985           enddo
14986 !          do k=1,3
14987 !            ghalf=0.5D0*ggg(k)
14988 !            gelc(k,i)=gelc(k,i)+ghalf
14989 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
14990 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14991 !            gelc(k,j)=gelc(k,j)+ghalf
14992 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
14993 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14994 !          enddo
14995 !grad          do k=i+1,j-1
14996 !grad            do l=1,3
14997 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14998 !grad            enddo
14999 !grad          enddo
15000           do k=1,3
15001             gelc(k,i)=gelc(k,i) &
15002                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15003                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
15004                      *sss_ele_cut
15005             gelc(k,j)=gelc(k,j) &
15006                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15007                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15008                      *sss_ele_cut
15009             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15010             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15011           enddo
15012           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
15013               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
15014               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15015 !
15016 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
15017 !   energy of a peptide unit is assumed in the form of a second-order
15018 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
15019 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
15020 !   are computed for EVERY pair of non-contiguous peptide groups.
15021 !
15022           if (j.lt.nres-1) then
15023             j1=j+1
15024             j2=j-1
15025           else
15026             j1=j-1
15027             j2=j-2
15028           endif
15029           kkk=0
15030           do k=1,2
15031             do l=1,2
15032               kkk=kkk+1
15033               muij(kkk)=mu(k,i)*mu(l,j)
15034             enddo
15035           enddo
15036 !d         write (iout,*) 'EELEC: i',i,' j',j
15037 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
15038 !d          write(iout,*) 'muij',muij
15039           ury=scalar(uy(1,i),erij)
15040           urz=scalar(uz(1,i),erij)
15041           vry=scalar(uy(1,j),erij)
15042           vrz=scalar(uz(1,j),erij)
15043           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
15044           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
15045           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
15046           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
15047           fac=dsqrt(-ael6i)*r3ij
15048           a22=a22*fac
15049           a23=a23*fac
15050           a32=a32*fac
15051           a33=a33*fac
15052 !d          write (iout,'(4i5,4f10.5)')
15053 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
15054 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
15055 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
15056 !d     &      uy(:,j),uz(:,j)
15057 !d          write (iout,'(4f10.5)')
15058 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
15059 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
15060 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
15061 !d           write (iout,'(9f10.5/)')
15062 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
15063 ! Derivatives of the elements of A in virtual-bond vectors
15064           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
15065           do k=1,3
15066             uryg(k,1)=scalar(erder(1,k),uy(1,i))
15067             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
15068             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
15069             urzg(k,1)=scalar(erder(1,k),uz(1,i))
15070             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
15071             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
15072             vryg(k,1)=scalar(erder(1,k),uy(1,j))
15073             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
15074             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
15075             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
15076             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
15077             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
15078           enddo
15079 ! Compute radial contributions to the gradient
15080           facr=-3.0d0*rrmij
15081           a22der=a22*facr
15082           a23der=a23*facr
15083           a32der=a32*facr
15084           a33der=a33*facr
15085           agg(1,1)=a22der*xj
15086           agg(2,1)=a22der*yj
15087           agg(3,1)=a22der*zj
15088           agg(1,2)=a23der*xj
15089           agg(2,2)=a23der*yj
15090           agg(3,2)=a23der*zj
15091           agg(1,3)=a32der*xj
15092           agg(2,3)=a32der*yj
15093           agg(3,3)=a32der*zj
15094           agg(1,4)=a33der*xj
15095           agg(2,4)=a33der*yj
15096           agg(3,4)=a33der*zj
15097 ! Add the contributions coming from er
15098           fac3=-3.0d0*fac
15099           do k=1,3
15100             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
15101             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
15102             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
15103             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
15104           enddo
15105           do k=1,3
15106 ! Derivatives in DC(i)
15107 !grad            ghalf1=0.5d0*agg(k,1)
15108 !grad            ghalf2=0.5d0*agg(k,2)
15109 !grad            ghalf3=0.5d0*agg(k,3)
15110 !grad            ghalf4=0.5d0*agg(k,4)
15111             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
15112             -3.0d0*uryg(k,2)*vry)!+ghalf1
15113             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
15114             -3.0d0*uryg(k,2)*vrz)!+ghalf2
15115             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
15116             -3.0d0*urzg(k,2)*vry)!+ghalf3
15117             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
15118             -3.0d0*urzg(k,2)*vrz)!+ghalf4
15119 ! Derivatives in DC(i+1)
15120             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
15121             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
15122             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
15123             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
15124             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
15125             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
15126             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
15127             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
15128 ! Derivatives in DC(j)
15129             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
15130             -3.0d0*vryg(k,2)*ury)!+ghalf1
15131             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
15132             -3.0d0*vrzg(k,2)*ury)!+ghalf2
15133             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
15134             -3.0d0*vryg(k,2)*urz)!+ghalf3
15135             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
15136             -3.0d0*vrzg(k,2)*urz)!+ghalf4
15137 ! Derivatives in DC(j+1) or DC(nres-1)
15138             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
15139             -3.0d0*vryg(k,3)*ury)
15140             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
15141             -3.0d0*vrzg(k,3)*ury)
15142             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
15143             -3.0d0*vryg(k,3)*urz)
15144             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
15145             -3.0d0*vrzg(k,3)*urz)
15146 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
15147 !grad              do l=1,4
15148 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
15149 !grad              enddo
15150 !grad            endif
15151           enddo
15152           acipa(1,1)=a22
15153           acipa(1,2)=a23
15154           acipa(2,1)=a32
15155           acipa(2,2)=a33
15156           a22=-a22
15157           a23=-a23
15158           do l=1,2
15159             do k=1,3
15160               agg(k,l)=-agg(k,l)
15161               aggi(k,l)=-aggi(k,l)
15162               aggi1(k,l)=-aggi1(k,l)
15163               aggj(k,l)=-aggj(k,l)
15164               aggj1(k,l)=-aggj1(k,l)
15165             enddo
15166           enddo
15167           if (j.lt.nres-1) then
15168             a22=-a22
15169             a32=-a32
15170             do l=1,3,2
15171               do k=1,3
15172                 agg(k,l)=-agg(k,l)
15173                 aggi(k,l)=-aggi(k,l)
15174                 aggi1(k,l)=-aggi1(k,l)
15175                 aggj(k,l)=-aggj(k,l)
15176                 aggj1(k,l)=-aggj1(k,l)
15177               enddo
15178             enddo
15179           else
15180             a22=-a22
15181             a23=-a23
15182             a32=-a32
15183             a33=-a33
15184             do l=1,4
15185               do k=1,3
15186                 agg(k,l)=-agg(k,l)
15187                 aggi(k,l)=-aggi(k,l)
15188                 aggi1(k,l)=-aggi1(k,l)
15189                 aggj(k,l)=-aggj(k,l)
15190                 aggj1(k,l)=-aggj1(k,l)
15191               enddo
15192             enddo
15193           endif
15194           ENDIF ! WCORR
15195           IF (wel_loc.gt.0.0d0) THEN
15196 ! Contribution to the local-electrostatic energy coming from the i-j pair
15197           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
15198            +a33*muij(4)
15199 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
15200 !           print *,"EELLOC",i,gel_loc_loc(i-1)
15201           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
15202                   'eelloc',i,j,eel_loc_ij
15203 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
15204
15205           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
15206 ! Partial derivatives in virtual-bond dihedral angles gamma
15207           if (i.gt.1) &
15208           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
15209                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
15210                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
15211                  *sss_ele_cut
15212           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
15213                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
15214                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
15215                  *sss_ele_cut
15216            xtemp(1)=xj
15217            xtemp(2)=yj
15218            xtemp(3)=zj
15219
15220 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
15221           do l=1,3
15222             ggg(l)=(agg(l,1)*muij(1)+ &
15223                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
15224             *sss_ele_cut &
15225              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
15226
15227             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
15228             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
15229 !grad            ghalf=0.5d0*ggg(l)
15230 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
15231 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
15232           enddo
15233 !grad          do k=i+1,j2
15234 !grad            do l=1,3
15235 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
15236 !grad            enddo
15237 !grad          enddo
15238 ! Remaining derivatives of eello
15239           do l=1,3
15240             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
15241                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
15242             *sss_ele_cut
15243
15244             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
15245                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
15246             *sss_ele_cut
15247
15248             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
15249                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
15250             *sss_ele_cut
15251
15252             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
15253                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
15254             *sss_ele_cut
15255
15256           enddo
15257           ENDIF
15258 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
15259 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
15260           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
15261              .and. num_conti.le.maxconts) then
15262 !            write (iout,*) i,j," entered corr"
15263 !
15264 ! Calculate the contact function. The ith column of the array JCONT will
15265 ! contain the numbers of atoms that make contacts with the atom I (of numbers
15266 ! greater than I). The arrays FACONT and GACONT will contain the values of
15267 ! the contact function and its derivative.
15268 !           r0ij=1.02D0*rpp(iteli,itelj)
15269 !           r0ij=1.11D0*rpp(iteli,itelj)
15270             r0ij=2.20D0*rpp(iteli,itelj)
15271 !           r0ij=1.55D0*rpp(iteli,itelj)
15272             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
15273 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15274             if (fcont.gt.0.0D0) then
15275               num_conti=num_conti+1
15276               if (num_conti.gt.maxconts) then
15277 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15278                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
15279                                ' will skip next contacts for this conf.',num_conti
15280               else
15281                 jcont_hb(num_conti,i)=j
15282 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
15283 !d     &           " jcont_hb",jcont_hb(num_conti,i)
15284                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
15285                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15286 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
15287 !  terms.
15288                 d_cont(num_conti,i)=rij
15289 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
15290 !     --- Electrostatic-interaction matrix ---
15291                 a_chuj(1,1,num_conti,i)=a22
15292                 a_chuj(1,2,num_conti,i)=a23
15293                 a_chuj(2,1,num_conti,i)=a32
15294                 a_chuj(2,2,num_conti,i)=a33
15295 !     --- Gradient of rij
15296                 do kkk=1,3
15297                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
15298                 enddo
15299                 kkll=0
15300                 do k=1,2
15301                   do l=1,2
15302                     kkll=kkll+1
15303                     do m=1,3
15304                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
15305                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
15306                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
15307                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
15308                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
15309                     enddo
15310                   enddo
15311                 enddo
15312                 ENDIF
15313                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
15314 ! Calculate contact energies
15315                 cosa4=4.0D0*cosa
15316                 wij=cosa-3.0D0*cosb*cosg
15317                 cosbg1=cosb+cosg
15318                 cosbg2=cosb-cosg
15319 !               fac3=dsqrt(-ael6i)/r0ij**3
15320                 fac3=dsqrt(-ael6i)*r3ij
15321 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
15322                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
15323                 if (ees0tmp.gt.0) then
15324                   ees0pij=dsqrt(ees0tmp)
15325                 else
15326                   ees0pij=0
15327                 endif
15328 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
15329                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
15330                 if (ees0tmp.gt.0) then
15331                   ees0mij=dsqrt(ees0tmp)
15332                 else
15333                   ees0mij=0
15334                 endif
15335 !               ees0mij=0.0D0
15336                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
15337                      *sss_ele_cut
15338
15339                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
15340                      *sss_ele_cut
15341
15342 ! Diagnostics. Comment out or remove after debugging!
15343 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
15344 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
15345 !               ees0m(num_conti,i)=0.0D0
15346 ! End diagnostics.
15347 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
15348 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
15349 ! Angular derivatives of the contact function
15350                 ees0pij1=fac3/ees0pij
15351                 ees0mij1=fac3/ees0mij
15352                 fac3p=-3.0D0*fac3*rrmij
15353                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
15354                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
15355 !               ees0mij1=0.0D0
15356                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
15357                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
15358                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
15359                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
15360                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
15361                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
15362                 ecosap=ecosa1+ecosa2
15363                 ecosbp=ecosb1+ecosb2
15364                 ecosgp=ecosg1+ecosg2
15365                 ecosam=ecosa1-ecosa2
15366                 ecosbm=ecosb1-ecosb2
15367                 ecosgm=ecosg1-ecosg2
15368 ! Diagnostics
15369 !               ecosap=ecosa1
15370 !               ecosbp=ecosb1
15371 !               ecosgp=ecosg1
15372 !               ecosam=0.0D0
15373 !               ecosbm=0.0D0
15374 !               ecosgm=0.0D0
15375 ! End diagnostics
15376                 facont_hb(num_conti,i)=fcont
15377                 fprimcont=fprimcont/rij
15378 !d              facont_hb(num_conti,i)=1.0D0
15379 ! Following line is for diagnostics.
15380 !d              fprimcont=0.0D0
15381                 do k=1,3
15382                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15383                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15384                 enddo
15385                 do k=1,3
15386                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
15387                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
15388                 enddo
15389 !                gggp(1)=gggp(1)+ees0pijp*xj
15390 !                gggp(2)=gggp(2)+ees0pijp*yj
15391 !                gggp(3)=gggp(3)+ees0pijp*zj
15392 !                gggm(1)=gggm(1)+ees0mijp*xj
15393 !                gggm(2)=gggm(2)+ees0mijp*yj
15394 !                gggm(3)=gggm(3)+ees0mijp*zj
15395                 gggp(1)=gggp(1)+ees0pijp*xj &
15396                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15397                 gggp(2)=gggp(2)+ees0pijp*yj &
15398                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15399                 gggp(3)=gggp(3)+ees0pijp*zj &
15400                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15401
15402                 gggm(1)=gggm(1)+ees0mijp*xj &
15403                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15404
15405                 gggm(2)=gggm(2)+ees0mijp*yj &
15406                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15407
15408                 gggm(3)=gggm(3)+ees0mijp*zj &
15409                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15410
15411 ! Derivatives due to the contact function
15412                 gacont_hbr(1,num_conti,i)=fprimcont*xj
15413                 gacont_hbr(2,num_conti,i)=fprimcont*yj
15414                 gacont_hbr(3,num_conti,i)=fprimcont*zj
15415                 do k=1,3
15416 !
15417 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
15418 !          following the change of gradient-summation algorithm.
15419 !
15420 !grad                  ghalfp=0.5D0*gggp(k)
15421 !grad                  ghalfm=0.5D0*gggm(k)
15422 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
15423 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15424 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15425 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
15426 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15427 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15428 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
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 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
15433 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15434 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15435 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
15436                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
15437                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15438                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15439                      *sss_ele_cut
15440
15441                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
15442                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15443                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15444                      *sss_ele_cut
15445
15446                   gacontp_hb3(k,num_conti,i)=gggp(k) &
15447                      *sss_ele_cut
15448
15449                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
15450                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15451                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15452                      *sss_ele_cut
15453
15454                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
15455                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15456                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
15457                      *sss_ele_cut
15458
15459                   gacontm_hb3(k,num_conti,i)=gggm(k) &
15460                      *sss_ele_cut
15461
15462                 enddo
15463               ENDIF ! wcorr
15464               endif  ! num_conti.le.maxconts
15465             endif  ! fcont.gt.0
15466           endif    ! j.gt.i+1
15467           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
15468             do k=1,4
15469               do l=1,3
15470                 ghalf=0.5d0*agg(l,k)
15471                 aggi(l,k)=aggi(l,k)+ghalf
15472                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
15473                 aggj(l,k)=aggj(l,k)+ghalf
15474               enddo
15475             enddo
15476             if (j.eq.nres-1 .and. i.lt.j-2) then
15477               do k=1,4
15478                 do l=1,3
15479                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
15480                 enddo
15481               enddo
15482             endif
15483           endif
15484  128      continue
15485 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
15486       return
15487       end subroutine eelecij_scale
15488 !-----------------------------------------------------------------------------
15489       subroutine evdwpp_short(evdw1)
15490 !
15491 ! Compute Evdwpp
15492 !
15493 !      implicit real*8 (a-h,o-z)
15494 !      include 'DIMENSIONS'
15495 !      include 'COMMON.CONTROL'
15496 !      include 'COMMON.IOUNITS'
15497 !      include 'COMMON.GEO'
15498 !      include 'COMMON.VAR'
15499 !      include 'COMMON.LOCAL'
15500 !      include 'COMMON.CHAIN'
15501 !      include 'COMMON.DERIV'
15502 !      include 'COMMON.INTERACT'
15503 !      include 'COMMON.CONTACTS'
15504 !      include 'COMMON.TORSION'
15505 !      include 'COMMON.VECTORS'
15506 !      include 'COMMON.FFIELD'
15507       real(kind=8),dimension(3) :: ggg
15508 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15509 #ifdef MOMENT
15510       real(kind=8) :: scal_el=1.0d0
15511 #else
15512       real(kind=8) :: scal_el=0.5d0
15513 #endif
15514 !el local variables
15515       integer :: i,j,k,iteli,itelj,num_conti,isubchap
15516       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
15517       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
15518                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15519                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
15520       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15521                     dist_temp, dist_init,sss_grad,sslipi,ssgradlipi,&
15522                    sslipj,ssgradlipj,faclipij2
15523       integer xshift,yshift,zshift
15524
15525
15526       evdw1=0.0D0
15527 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
15528 !     & " iatel_e_vdw",iatel_e_vdw
15529       call flush(iout)
15530       do i=iatel_s_vdw,iatel_e_vdw
15531         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
15532         dxi=dc(1,i)
15533         dyi=dc(2,i)
15534         dzi=dc(3,i)
15535         dx_normi=dc_norm(1,i)
15536         dy_normi=dc_norm(2,i)
15537         dz_normi=dc_norm(3,i)
15538         xmedi=c(1,i)+0.5d0*dxi
15539         ymedi=c(2,i)+0.5d0*dyi
15540         zmedi=c(3,i)+0.5d0*dzi
15541         call to_box(xmedi,ymedi,zmedi)
15542         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
15543         num_conti=0
15544 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
15545 !     &   ' ielend',ielend_vdw(i)
15546         call flush(iout)
15547         do j=ielstart_vdw(i),ielend_vdw(i)
15548           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15549 !el          ind=ind+1
15550           iteli=itel(i)
15551           itelj=itel(j)
15552           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15553           aaa=app(iteli,itelj)
15554           bbb=bpp(iteli,itelj)
15555           dxj=dc(1,j)
15556           dyj=dc(2,j)
15557           dzj=dc(3,j)
15558           dx_normj=dc_norm(1,j)
15559           dy_normj=dc_norm(2,j)
15560           dz_normj=dc_norm(3,j)
15561 !          xj=c(1,j)+0.5D0*dxj-xmedi
15562 !          yj=c(2,j)+0.5D0*dyj-ymedi
15563 !          zj=c(3,j)+0.5D0*dzj-zmedi
15564           xj=c(1,j)+0.5D0*dxj
15565           yj=c(2,j)+0.5D0*dyj
15566           zj=c(3,j)+0.5D0*dzj
15567           call to_box(xj,yj,zj)
15568           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15569           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
15570           xj=boxshift(xj-xmedi,boxxsize)
15571           yj=boxshift(yj-ymedi,boxysize)
15572           zj=boxshift(zj-zmedi,boxzsize)
15573           rij=xj*xj+yj*yj+zj*zj
15574           rrmij=1.0D0/rij
15575           rij=dsqrt(rij)
15576           sss=sscale(rij/rpp(iteli,itelj))
15577             sss_ele_cut=sscale_ele(rij)
15578             sss_ele_grad=sscagrad_ele(rij)
15579             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15580             if (sss_ele_cut.le.0.0) cycle
15581           if (sss.gt.0.0d0) then
15582             rmij=1.0D0/rij
15583             r3ij=rrmij*rmij
15584             r6ij=r3ij*r3ij
15585             ev1=aaa*r6ij*r6ij
15586 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15587             if (j.eq.i+2) ev1=scal_el*ev1
15588             ev2=bbb*r6ij
15589             evdwij=ev1+ev2
15590             if (energy_dec) then
15591               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15592             endif
15593             evdw1=evdw1+evdwij*sss*sss_ele_cut
15594 !
15595 ! Calculate contributions to the Cartesian gradient.
15596 !
15597             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
15598 !            ggg(1)=facvdw*xj
15599 !            ggg(2)=facvdw*yj
15600 !            ggg(3)=facvdw*zj
15601           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
15602           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15603           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
15604           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15605           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
15606           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15607
15608             do k=1,3
15609               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15610               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15611             enddo
15612           endif
15613         enddo ! j
15614       enddo   ! i
15615       return
15616       end subroutine evdwpp_short
15617 !-----------------------------------------------------------------------------
15618       subroutine escp_long(evdw2,evdw2_14)
15619 !
15620 ! This subroutine calculates the excluded-volume interaction energy between
15621 ! peptide-group centers and side chains and its gradient in virtual-bond and
15622 ! side-chain vectors.
15623 !
15624 !      implicit real*8 (a-h,o-z)
15625 !      include 'DIMENSIONS'
15626 !      include 'COMMON.GEO'
15627 !      include 'COMMON.VAR'
15628 !      include 'COMMON.LOCAL'
15629 !      include 'COMMON.CHAIN'
15630 !      include 'COMMON.DERIV'
15631 !      include 'COMMON.INTERACT'
15632 !      include 'COMMON.FFIELD'
15633 !      include 'COMMON.IOUNITS'
15634 !      include 'COMMON.CONTROL'
15635       real(kind=8),dimension(3) :: ggg
15636 !el local variables
15637       integer :: i,iint,j,k,iteli,itypj,subchap
15638       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15639       real(kind=8) :: evdw2,evdw2_14,evdwij
15640       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15641                     dist_temp, dist_init
15642
15643       evdw2=0.0D0
15644       evdw2_14=0.0d0
15645 !d    print '(a)','Enter ESCP'
15646 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15647       do i=iatscp_s,iatscp_e
15648         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15649         iteli=itel(i)
15650         xi=0.5D0*(c(1,i)+c(1,i+1))
15651         yi=0.5D0*(c(2,i)+c(2,i+1))
15652         zi=0.5D0*(c(3,i)+c(3,i+1))
15653         call to_box(xi,yi,zi)
15654         do iint=1,nscp_gr(i)
15655
15656         do j=iscpstart(i,iint),iscpend(i,iint)
15657           itypj=itype(j,1)
15658           if (itypj.eq.ntyp1) cycle
15659 ! Uncomment following three lines for SC-p interactions
15660 !         xj=c(1,nres+j)-xi
15661 !         yj=c(2,nres+j)-yi
15662 !         zj=c(3,nres+j)-zi
15663 ! Uncomment following three lines for Ca-p interactions
15664           xj=c(1,j)
15665           yj=c(2,j)
15666           zj=c(3,j)
15667           call to_box(xj,yj,zj)
15668           xj=boxshift(xj-xi,boxxsize)
15669           yj=boxshift(yj-yi,boxysize)
15670           zj=boxshift(zj-zi,boxzsize)
15671           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15672
15673           rij=dsqrt(1.0d0/rrij)
15674             sss_ele_cut=sscale_ele(rij)
15675             sss_ele_grad=sscagrad_ele(rij)
15676 !            print *,sss_ele_cut,sss_ele_grad,&
15677 !            (rij),r_cut_ele,rlamb_ele
15678             if (sss_ele_cut.le.0.0) cycle
15679           sss=sscale((rij/rscp(itypj,iteli)))
15680           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15681           if (sss.lt.1.0d0) then
15682
15683             fac=rrij**expon2
15684             e1=fac*fac*aad(itypj,iteli)
15685             e2=fac*bad(itypj,iteli)
15686             if (iabs(j-i) .le. 2) then
15687               e1=scal14*e1
15688               e2=scal14*e2
15689               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
15690             endif
15691             evdwij=e1+e2
15692             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
15693             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15694                 'evdw2',i,j,sss,evdwij
15695 !
15696 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15697 !
15698             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
15699             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
15700             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15701             ggg(1)=xj*fac
15702             ggg(2)=yj*fac
15703             ggg(3)=zj*fac
15704 ! Uncomment following three lines for SC-p interactions
15705 !           do k=1,3
15706 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15707 !           enddo
15708 ! Uncomment following line for SC-p interactions
15709 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15710             do k=1,3
15711               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15712               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15713             enddo
15714           endif
15715         enddo
15716
15717         enddo ! iint
15718       enddo ! i
15719       do i=1,nct
15720         do j=1,3
15721           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15722           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15723           gradx_scp(j,i)=expon*gradx_scp(j,i)
15724         enddo
15725       enddo
15726 !******************************************************************************
15727 !
15728 !                              N O T E !!!
15729 !
15730 ! To save time the factor EXPON has been extracted from ALL components
15731 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15732 ! use!
15733 !
15734 !******************************************************************************
15735       return
15736       end subroutine escp_long
15737 !-----------------------------------------------------------------------------
15738       subroutine escp_short(evdw2,evdw2_14)
15739 !
15740 ! This subroutine calculates the excluded-volume interaction energy between
15741 ! peptide-group centers and side chains and its gradient in virtual-bond and
15742 ! side-chain vectors.
15743 !
15744 !      implicit real*8 (a-h,o-z)
15745 !      include 'DIMENSIONS'
15746 !      include 'COMMON.GEO'
15747 !      include 'COMMON.VAR'
15748 !      include 'COMMON.LOCAL'
15749 !      include 'COMMON.CHAIN'
15750 !      include 'COMMON.DERIV'
15751 !      include 'COMMON.INTERACT'
15752 !      include 'COMMON.FFIELD'
15753 !      include 'COMMON.IOUNITS'
15754 !      include 'COMMON.CONTROL'
15755       real(kind=8),dimension(3) :: ggg
15756 !el local variables
15757       integer :: i,iint,j,k,iteli,itypj,subchap
15758       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15759       real(kind=8) :: evdw2,evdw2_14,evdwij
15760       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15761                     dist_temp, dist_init
15762
15763       evdw2=0.0D0
15764       evdw2_14=0.0d0
15765 !d    print '(a)','Enter ESCP'
15766 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15767       do i=iatscp_s,iatscp_e
15768         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15769         iteli=itel(i)
15770         xi=0.5D0*(c(1,i)+c(1,i+1))
15771         yi=0.5D0*(c(2,i)+c(2,i+1))
15772         zi=0.5D0*(c(3,i)+c(3,i+1))
15773         call to_box(xi,yi,zi)
15774         if (zi.lt.0) zi=zi+boxzsize
15775
15776         do iint=1,nscp_gr(i)
15777
15778         do j=iscpstart(i,iint),iscpend(i,iint)
15779           itypj=itype(j,1)
15780           if (itypj.eq.ntyp1) cycle
15781 ! Uncomment following three lines for SC-p interactions
15782 !         xj=c(1,nres+j)-xi
15783 !         yj=c(2,nres+j)-yi
15784 !         zj=c(3,nres+j)-zi
15785 ! Uncomment following three lines for Ca-p interactions
15786 !          xj=c(1,j)-xi
15787 !          yj=c(2,j)-yi
15788 !          zj=c(3,j)-zi
15789           xj=c(1,j)
15790           yj=c(2,j)
15791           zj=c(3,j)
15792           call to_box(xj,yj,zj)
15793           xj=boxshift(xj-xi,boxxsize)
15794           yj=boxshift(yj-yi,boxysize)
15795           zj=boxshift(zj-zi,boxzsize)
15796           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15797           rij=dsqrt(1.0d0/rrij)
15798             sss_ele_cut=sscale_ele(rij)
15799             sss_ele_grad=sscagrad_ele(rij)
15800 !            print *,sss_ele_cut,sss_ele_grad,&
15801 !            (rij),r_cut_ele,rlamb_ele
15802             if (sss_ele_cut.le.0.0) cycle
15803           sss=sscale(rij/rscp(itypj,iteli))
15804           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15805           if (sss.gt.0.0d0) then
15806
15807             fac=rrij**expon2
15808             e1=fac*fac*aad(itypj,iteli)
15809             e2=fac*bad(itypj,iteli)
15810             if (iabs(j-i) .le. 2) then
15811               e1=scal14*e1
15812               e2=scal14*e2
15813               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
15814             endif
15815             evdwij=e1+e2
15816             evdw2=evdw2+evdwij*sss*sss_ele_cut
15817             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15818                 'evdw2',i,j,sss,evdwij
15819 !
15820 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15821 !
15822             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
15823             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
15824             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15825
15826             ggg(1)=xj*fac
15827             ggg(2)=yj*fac
15828             ggg(3)=zj*fac
15829 ! Uncomment following three lines for SC-p interactions
15830 !           do k=1,3
15831 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15832 !           enddo
15833 ! Uncomment following line for SC-p interactions
15834 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15835             do k=1,3
15836               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15837               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15838             enddo
15839           endif
15840         enddo
15841
15842         enddo ! iint
15843       enddo ! i
15844       do i=1,nct
15845         do j=1,3
15846           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15847           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15848           gradx_scp(j,i)=expon*gradx_scp(j,i)
15849         enddo
15850       enddo
15851 !******************************************************************************
15852 !
15853 !                              N O T E !!!
15854 !
15855 ! To save time the factor EXPON has been extracted from ALL components
15856 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15857 ! use!
15858 !
15859 !******************************************************************************
15860       return
15861       end subroutine escp_short
15862 !-----------------------------------------------------------------------------
15863 ! energy_p_new-sep_barrier.F
15864 !-----------------------------------------------------------------------------
15865       subroutine sc_grad_scale(scalfac)
15866 !      implicit real*8 (a-h,o-z)
15867       use calc_data
15868 !      include 'DIMENSIONS'
15869 !      include 'COMMON.CHAIN'
15870 !      include 'COMMON.DERIV'
15871 !      include 'COMMON.CALC'
15872 !      include 'COMMON.IOUNITS'
15873       real(kind=8),dimension(3) :: dcosom1,dcosom2
15874       real(kind=8) :: scalfac
15875 !el local variables
15876 !      integer :: i,j,k,l
15877
15878       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15879       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15880       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
15881            -2.0D0*alf12*eps3der+sigder*sigsq_om12
15882 ! diagnostics only
15883 !      eom1=0.0d0
15884 !      eom2=0.0d0
15885 !      eom12=evdwij*eps1_om12
15886 ! end diagnostics
15887 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
15888 !     &  " sigder",sigder
15889 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
15890 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
15891       do k=1,3
15892         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
15893         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
15894       enddo
15895       do k=1,3
15896         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
15897          *sss_ele_cut
15898       enddo
15899 !      write (iout,*) "gg",(gg(k),k=1,3)
15900       do k=1,3
15901         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15902                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15903                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
15904                  *sss_ele_cut
15905         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15906                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15907                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
15908          *sss_ele_cut
15909 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
15910 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15911 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
15912 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15913       enddo
15914 !
15915 ! Calculate the components of the gradient in DC and X
15916 !
15917       do l=1,3
15918         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15919         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15920       enddo
15921       return
15922       end subroutine sc_grad_scale
15923 !-----------------------------------------------------------------------------
15924 ! energy_split-sep.F
15925 !-----------------------------------------------------------------------------
15926       subroutine etotal_long(energia)
15927 !
15928 ! Compute the long-range slow-varying contributions to the energy
15929 !
15930 !      implicit real*8 (a-h,o-z)
15931 !      include 'DIMENSIONS'
15932       use MD_data, only: totT,usampl,eq_time
15933 #ifndef ISNAN
15934       external proc_proc
15935 #ifdef WINPGI
15936 !MS$ATTRIBUTES C ::  proc_proc
15937 #endif
15938 #endif
15939 #ifdef MPI
15940       include "mpif.h"
15941       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
15942 #endif
15943 !      include 'COMMON.SETUP'
15944 !      include 'COMMON.IOUNITS'
15945 !      include 'COMMON.FFIELD'
15946 !      include 'COMMON.DERIV'
15947 !      include 'COMMON.INTERACT'
15948 !      include 'COMMON.SBRIDGE'
15949 !      include 'COMMON.CHAIN'
15950 !      include 'COMMON.VAR'
15951 !      include 'COMMON.LOCAL'
15952 !      include 'COMMON.MD'
15953       real(kind=8),dimension(0:n_ene) :: energia
15954 !el local variables
15955       integer :: i,n_corr,n_corr1,ierror,ierr
15956       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
15957                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
15958                   ecorr,ecorr5,ecorr6,eturn6,time00
15959 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
15960 !elwrite(iout,*)"in etotal long"
15961
15962       if (modecalc.eq.12.or.modecalc.eq.14) then
15963 #ifdef MPI
15964 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
15965 #else
15966         call int_from_cart1(.false.)
15967 #endif
15968       endif
15969 !elwrite(iout,*)"in etotal long"
15970
15971 #ifdef MPI
15972 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15973 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15974       call flush(iout)
15975       if (nfgtasks.gt.1) then
15976         time00=MPI_Wtime()
15977 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15978         if (fg_rank.eq.0) then
15979           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15980 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15981 !          call flush(iout)
15982 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15983 ! FG slaves as WEIGHTS array.
15984           weights_(1)=wsc
15985           weights_(2)=wscp
15986           weights_(3)=welec
15987           weights_(4)=wcorr
15988           weights_(5)=wcorr5
15989           weights_(6)=wcorr6
15990           weights_(7)=wel_loc
15991           weights_(8)=wturn3
15992           weights_(9)=wturn4
15993           weights_(10)=wturn6
15994           weights_(11)=wang
15995           weights_(12)=wscloc
15996           weights_(13)=wtor
15997           weights_(14)=wtor_d
15998           weights_(15)=wstrain
15999           weights_(16)=wvdwpp
16000           weights_(17)=wbond
16001           weights_(18)=scal14
16002           weights_(21)=wsccor
16003 ! FG Master broadcasts the WEIGHTS_ array
16004           call MPI_Bcast(weights_(1),n_ene,&
16005               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16006         else
16007 ! FG slaves receive the WEIGHTS array
16008           call MPI_Bcast(weights(1),n_ene,&
16009               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16010           wsc=weights(1)
16011           wscp=weights(2)
16012           welec=weights(3)
16013           wcorr=weights(4)
16014           wcorr5=weights(5)
16015           wcorr6=weights(6)
16016           wel_loc=weights(7)
16017           wturn3=weights(8)
16018           wturn4=weights(9)
16019           wturn6=weights(10)
16020           wang=weights(11)
16021           wscloc=weights(12)
16022           wtor=weights(13)
16023           wtor_d=weights(14)
16024           wstrain=weights(15)
16025           wvdwpp=weights(16)
16026           wbond=weights(17)
16027           scal14=weights(18)
16028           wsccor=weights(21)
16029         endif
16030         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
16031           king,FG_COMM,IERR)
16032          time_Bcast=time_Bcast+MPI_Wtime()-time00
16033          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
16034 !        call chainbuild_cart
16035 !        call int_from_cart1(.false.)
16036       endif
16037 !      write (iout,*) 'Processor',myrank,
16038 !     &  ' calling etotal_short ipot=',ipot
16039 !      call flush(iout)
16040 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16041 #endif
16042 !d    print *,'nnt=',nnt,' nct=',nct
16043 !
16044 !elwrite(iout,*)"in etotal long"
16045 ! Compute the side-chain and electrostatic interaction energy
16046 !
16047       goto (101,102,103,104,105,106) ipot
16048 ! Lennard-Jones potential.
16049   101 call elj_long(evdw)
16050 !d    print '(a)','Exit ELJ'
16051       goto 107
16052 ! Lennard-Jones-Kihara potential (shifted).
16053   102 call eljk_long(evdw)
16054       goto 107
16055 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16056   103 call ebp_long(evdw)
16057       goto 107
16058 ! Gay-Berne potential (shifted LJ, angular dependence).
16059   104 call egb_long(evdw)
16060       goto 107
16061 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16062   105 call egbv_long(evdw)
16063       goto 107
16064 ! Soft-sphere potential
16065   106 call e_softsphere(evdw)
16066 !
16067 ! Calculate electrostatic (H-bonding) energy of the main chain.
16068 !
16069   107 continue
16070       call vec_and_deriv
16071       if (ipot.lt.6) then
16072 #ifdef SPLITELE
16073          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
16074              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16075              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16076              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16077 #else
16078          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
16079              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16080              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16081              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16082 #endif
16083            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
16084          else
16085             ees=0
16086             evdw1=0
16087             eel_loc=0
16088             eello_turn3=0
16089             eello_turn4=0
16090          endif
16091       else
16092 !        write (iout,*) "Soft-spheer ELEC potential"
16093         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
16094          eello_turn4)
16095       endif
16096 !
16097 ! Calculate excluded-volume interaction energy between peptide groups
16098 ! and side chains.
16099 !
16100       if (ipot.lt.6) then
16101        if(wscp.gt.0d0) then
16102         call escp_long(evdw2,evdw2_14)
16103        else
16104         evdw2=0
16105         evdw2_14=0
16106        endif
16107       else
16108         call escp_soft_sphere(evdw2,evdw2_14)
16109       endif
16110 !
16111 ! 12/1/95 Multi-body terms
16112 !
16113       n_corr=0
16114       n_corr1=0
16115       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
16116           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
16117          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
16118 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
16119 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
16120       else
16121          ecorr=0.0d0
16122          ecorr5=0.0d0
16123          ecorr6=0.0d0
16124          eturn6=0.0d0
16125       endif
16126       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
16127          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
16128       endif
16129 !
16130 ! If performing constraint dynamics, call the constraint energy
16131 !  after the equilibration time
16132       if(usampl.and.totT.gt.eq_time) then
16133          call EconstrQ
16134          call Econstr_back
16135       else
16136          Uconst=0.0d0
16137          Uconst_back=0.0d0
16138       endif
16139 !
16140 ! Sum the energies
16141 !
16142       do i=1,n_ene
16143         energia(i)=0.0d0
16144       enddo
16145       energia(1)=evdw
16146 #ifdef SCP14
16147       energia(2)=evdw2-evdw2_14
16148       energia(18)=evdw2_14
16149 #else
16150       energia(2)=evdw2
16151       energia(18)=0.0d0
16152 #endif
16153 #ifdef SPLITELE
16154       energia(3)=ees
16155       energia(16)=evdw1
16156 #else
16157       energia(3)=ees+evdw1
16158       energia(16)=0.0d0
16159 #endif
16160       energia(4)=ecorr
16161       energia(5)=ecorr5
16162       energia(6)=ecorr6
16163       energia(7)=eel_loc
16164       energia(8)=eello_turn3
16165       energia(9)=eello_turn4
16166       energia(10)=eturn6
16167       energia(20)=Uconst+Uconst_back
16168       call sum_energy(energia,.true.)
16169 !      write (iout,*) "Exit ETOTAL_LONG"
16170       call flush(iout)
16171       return
16172       end subroutine etotal_long
16173 !-----------------------------------------------------------------------------
16174       subroutine etotal_short(energia)
16175 !
16176 ! Compute the short-range fast-varying contributions to the energy
16177 !
16178 !      implicit real*8 (a-h,o-z)
16179 !      include 'DIMENSIONS'
16180 #ifndef ISNAN
16181       external proc_proc
16182 #ifdef WINPGI
16183 !MS$ATTRIBUTES C ::  proc_proc
16184 #endif
16185 #endif
16186 #ifdef MPI
16187       include "mpif.h"
16188       integer :: ierror,ierr
16189       real(kind=8),dimension(n_ene) :: weights_
16190       real(kind=8) :: time00
16191 #endif
16192 !      include 'COMMON.SETUP'
16193 !      include 'COMMON.IOUNITS'
16194 !      include 'COMMON.FFIELD'
16195 !      include 'COMMON.DERIV'
16196 !      include 'COMMON.INTERACT'
16197 !      include 'COMMON.SBRIDGE'
16198 !      include 'COMMON.CHAIN'
16199 !      include 'COMMON.VAR'
16200 !      include 'COMMON.LOCAL'
16201       real(kind=8),dimension(0:n_ene) :: energia
16202 !el local variables
16203       integer :: i,nres6
16204       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
16205       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
16206       nres6=6*nres
16207
16208 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
16209 !      call flush(iout)
16210       if (modecalc.eq.12.or.modecalc.eq.14) then
16211 #ifdef MPI
16212         if (fg_rank.eq.0) call int_from_cart1(.false.)
16213 #else
16214         call int_from_cart1(.false.)
16215 #endif
16216       endif
16217 #ifdef MPI
16218 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
16219 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16220 !      call flush(iout)
16221       if (nfgtasks.gt.1) then
16222         time00=MPI_Wtime()
16223 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16224         if (fg_rank.eq.0) then
16225           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
16226 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16227 !          call flush(iout)
16228 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16229 ! FG slaves as WEIGHTS array.
16230           weights_(1)=wsc
16231           weights_(2)=wscp
16232           weights_(3)=welec
16233           weights_(4)=wcorr
16234           weights_(5)=wcorr5
16235           weights_(6)=wcorr6
16236           weights_(7)=wel_loc
16237           weights_(8)=wturn3
16238           weights_(9)=wturn4
16239           weights_(10)=wturn6
16240           weights_(11)=wang
16241           weights_(12)=wscloc
16242           weights_(13)=wtor
16243           weights_(14)=wtor_d
16244           weights_(15)=wstrain
16245           weights_(16)=wvdwpp
16246           weights_(17)=wbond
16247           weights_(18)=scal14
16248           weights_(21)=wsccor
16249 ! FG Master broadcasts the WEIGHTS_ array
16250           call MPI_Bcast(weights_(1),n_ene,&
16251               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16252         else
16253 ! FG slaves receive the WEIGHTS array
16254           call MPI_Bcast(weights(1),n_ene,&
16255               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16256           wsc=weights(1)
16257           wscp=weights(2)
16258           welec=weights(3)
16259           wcorr=weights(4)
16260           wcorr5=weights(5)
16261           wcorr6=weights(6)
16262           wel_loc=weights(7)
16263           wturn3=weights(8)
16264           wturn4=weights(9)
16265           wturn6=weights(10)
16266           wang=weights(11)
16267           wscloc=weights(12)
16268           wtor=weights(13)
16269           wtor_d=weights(14)
16270           wstrain=weights(15)
16271           wvdwpp=weights(16)
16272           wbond=weights(17)
16273           scal14=weights(18)
16274           wsccor=weights(21)
16275         endif
16276 !        write (iout,*),"Processor",myrank," BROADCAST weights"
16277         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
16278           king,FG_COMM,IERR)
16279 !        write (iout,*) "Processor",myrank," BROADCAST c"
16280         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
16281           king,FG_COMM,IERR)
16282 !        write (iout,*) "Processor",myrank," BROADCAST dc"
16283         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
16284           king,FG_COMM,IERR)
16285 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
16286         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
16287           king,FG_COMM,IERR)
16288 !        write (iout,*) "Processor",myrank," BROADCAST theta"
16289         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
16290           king,FG_COMM,IERR)
16291 !        write (iout,*) "Processor",myrank," BROADCAST phi"
16292         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
16293           king,FG_COMM,IERR)
16294 !        write (iout,*) "Processor",myrank," BROADCAST alph"
16295         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
16296           king,FG_COMM,IERR)
16297 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
16298         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
16299           king,FG_COMM,IERR)
16300 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
16301         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
16302           king,FG_COMM,IERR)
16303          time_Bcast=time_Bcast+MPI_Wtime()-time00
16304 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
16305       endif
16306 !      write (iout,*) 'Processor',myrank,
16307 !     &  ' calling etotal_short ipot=',ipot
16308 !      call flush(iout)
16309 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16310 #endif
16311 !      call int_from_cart1(.false.)
16312 !
16313 ! Compute the side-chain and electrostatic interaction energy
16314 !
16315       goto (101,102,103,104,105,106) ipot
16316 ! Lennard-Jones potential.
16317   101 call elj_short(evdw)
16318 !d    print '(a)','Exit ELJ'
16319       goto 107
16320 ! Lennard-Jones-Kihara potential (shifted).
16321   102 call eljk_short(evdw)
16322       goto 107
16323 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16324   103 call ebp_short(evdw)
16325       goto 107
16326 ! Gay-Berne potential (shifted LJ, angular dependence).
16327   104 call egb_short(evdw)
16328       goto 107
16329 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16330   105 call egbv_short(evdw)
16331       goto 107
16332 ! Soft-sphere potential - already dealt with in the long-range part
16333   106 evdw=0.0d0
16334 !  106 call e_softsphere_short(evdw)
16335 !
16336 ! Calculate electrostatic (H-bonding) energy of the main chain.
16337 !
16338   107 continue
16339 !
16340 ! Calculate the short-range part of Evdwpp
16341 !
16342       call evdwpp_short(evdw1)
16343 !
16344 ! Calculate the short-range part of ESCp
16345 !
16346       if (ipot.lt.6) then
16347        call escp_short(evdw2,evdw2_14)
16348       endif
16349 !
16350 ! Calculate the bond-stretching energy
16351 !
16352       call ebond(estr)
16353 !
16354 ! Calculate the disulfide-bridge and other energy and the contributions
16355 ! from other distance constraints.
16356       call edis(ehpb)
16357 !
16358 ! Calculate the virtual-bond-angle energy.
16359 !
16360 ! Calculate the SC local energy.
16361 !
16362       call vec_and_deriv
16363       call esc(escloc)
16364 !
16365       if (wang.gt.0d0) then
16366        if (tor_mode.eq.0) then
16367            call ebend(ebe)
16368        else
16369 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
16370 !C energy function
16371         call ebend_kcc(ebe)
16372        endif
16373       else
16374           ebe=0.0d0
16375       endif
16376       ethetacnstr=0.0d0
16377       if (with_theta_constr) call etheta_constr(ethetacnstr)
16378
16379 !       write(iout,*) "in etotal afer ebe",ipot
16380
16381 !      print *,"Processor",myrank," computed UB"
16382 !
16383 ! Calculate the SC local energy.
16384 !
16385       call esc(escloc)
16386 !elwrite(iout,*) "in etotal afer esc",ipot
16387 !      print *,"Processor",myrank," computed USC"
16388 !
16389 ! Calculate the virtual-bond torsional energy.
16390 !
16391 !d    print *,'nterm=',nterm
16392 !      if (wtor.gt.0) then
16393 !       call etor(etors,edihcnstr)
16394 !      else
16395 !       etors=0
16396 !       edihcnstr=0
16397 !      endif
16398       if (wtor.gt.0.0d0) then
16399          if (tor_mode.eq.0) then
16400            call etor(etors)
16401           else
16402 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
16403 !C energy function
16404         call etor_kcc(etors)
16405          endif
16406       else
16407            etors=0.0d0
16408       endif
16409       edihcnstr=0.0d0
16410       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
16411
16412 ! Calculate the virtual-bond torsional energy.
16413 !
16414 !
16415 ! 6/23/01 Calculate double-torsional energy
16416 !
16417       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
16418       call etor_d(etors_d)
16419       endif
16420 !
16421 ! 21/5/07 Calculate local sicdechain correlation energy
16422 !
16423       if (wsccor.gt.0.0d0) then
16424        call eback_sc_corr(esccor)
16425       else
16426        esccor=0.0d0
16427       endif
16428 !
16429 ! Put energy components into an array
16430 !
16431       do i=1,n_ene
16432        energia(i)=0.0d0
16433       enddo
16434       energia(1)=evdw
16435 #ifdef SCP14
16436       energia(2)=evdw2-evdw2_14
16437       energia(18)=evdw2_14
16438 #else
16439       energia(2)=evdw2
16440       energia(18)=0.0d0
16441 #endif
16442 #ifdef SPLITELE
16443       energia(16)=evdw1
16444 #else
16445       energia(3)=evdw1
16446 #endif
16447       energia(11)=ebe
16448       energia(12)=escloc
16449       energia(13)=etors
16450       energia(14)=etors_d
16451       energia(15)=ehpb
16452       energia(17)=estr
16453       energia(19)=edihcnstr
16454       energia(21)=esccor
16455 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
16456       call flush(iout)
16457       call sum_energy(energia,.true.)
16458 !      write (iout,*) "Exit ETOTAL_SHORT"
16459       call flush(iout)
16460       return
16461       end subroutine etotal_short
16462 !-----------------------------------------------------------------------------
16463 ! gnmr1.f
16464 !-----------------------------------------------------------------------------
16465       real(kind=8) function gnmr1(y,ymin,ymax)
16466 !      implicit none
16467       real(kind=8) :: y,ymin,ymax
16468       real(kind=8) :: wykl=4.0d0
16469       if (y.lt.ymin) then
16470         gnmr1=(ymin-y)**wykl/wykl
16471       else if (y.gt.ymax) then
16472        gnmr1=(y-ymax)**wykl/wykl
16473       else
16474        gnmr1=0.0d0
16475       endif
16476       return
16477       end function gnmr1
16478 !-----------------------------------------------------------------------------
16479       real(kind=8) function gnmr1prim(y,ymin,ymax)
16480 !      implicit none
16481       real(kind=8) :: y,ymin,ymax
16482       real(kind=8) :: wykl=4.0d0
16483       if (y.lt.ymin) then
16484        gnmr1prim=-(ymin-y)**(wykl-1)
16485       else if (y.gt.ymax) then
16486        gnmr1prim=(y-ymax)**(wykl-1)
16487       else
16488        gnmr1prim=0.0d0
16489       endif
16490       return
16491       end function gnmr1prim
16492 !----------------------------------------------------------------------------
16493       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
16494       real(kind=8) y,ymin,ymax,sigma
16495       real(kind=8) wykl /4.0d0/
16496       if (y.lt.ymin) then
16497         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
16498       else if (y.gt.ymax) then
16499        rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
16500       else
16501         rlornmr1=0.0d0
16502       endif
16503       return
16504       end function rlornmr1
16505 !------------------------------------------------------------------------------
16506       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
16507       real(kind=8) y,ymin,ymax,sigma
16508       real(kind=8) wykl /4.0d0/
16509       if (y.lt.ymin) then
16510         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
16511         ((ymin-y)**wykl+sigma**wykl)**2
16512       else if (y.gt.ymax) then
16513          rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
16514         ((y-ymax)**wykl+sigma**wykl)**2
16515       else
16516        rlornmr1prim=0.0d0
16517       endif
16518       return
16519       end function rlornmr1prim
16520
16521       real(kind=8) function harmonic(y,ymax)
16522 !      implicit none
16523       real(kind=8) :: y,ymax
16524       real(kind=8) :: wykl=2.0d0
16525       harmonic=(y-ymax)**wykl
16526       return
16527       end function harmonic
16528 !-----------------------------------------------------------------------------
16529       real(kind=8) function harmonicprim(y,ymax)
16530       real(kind=8) :: y,ymin,ymax
16531       real(kind=8) :: wykl=2.0d0
16532       harmonicprim=(y-ymax)*wykl
16533       return
16534       end function harmonicprim
16535 !-----------------------------------------------------------------------------
16536 ! gradient_p.F
16537 !-----------------------------------------------------------------------------
16538       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
16539
16540       use io_base, only:intout,briefout
16541 !      implicit real*8 (a-h,o-z)
16542 !      include 'DIMENSIONS'
16543 !      include 'COMMON.CHAIN'
16544 !      include 'COMMON.DERIV'
16545 !      include 'COMMON.VAR'
16546 !      include 'COMMON.INTERACT'
16547 !      include 'COMMON.FFIELD'
16548 !      include 'COMMON.MD'
16549 !      include 'COMMON.IOUNITS'
16550       real(kind=8),external :: ufparm
16551       integer :: uiparm(1)
16552       real(kind=8) :: urparm(1)
16553       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
16554       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
16555       integer :: n,nf,ind,ind1,i,k,j
16556 !
16557 ! This subroutine calculates total internal coordinate gradient.
16558 ! Depending on the number of function evaluations, either whole energy
16559 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
16560 ! internal coordinates are reevaluated or only the cartesian-in-internal
16561 ! coordinate derivatives are evaluated. The subroutine was designed to work
16562 ! with SUMSL.
16563 !
16564 !
16565       icg=mod(nf,2)+1
16566
16567 !d      print *,'grad',nf,icg
16568       if (nf-nfl+1) 20,30,40
16569    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
16570 !    write (iout,*) 'grad 20'
16571       if (nf.eq.0) return
16572       goto 40
16573    30 call var_to_geom(n,x)
16574       call chainbuild
16575 !    write (iout,*) 'grad 30'
16576 !
16577 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
16578 !
16579    40 call cartder
16580 !     write (iout,*) 'grad 40'
16581 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
16582 !
16583 ! Convert the Cartesian gradient into internal-coordinate gradient.
16584 !
16585       ind=0
16586       ind1=0
16587       do i=1,nres-2
16588       gthetai=0.0D0
16589       gphii=0.0D0
16590       do j=i+1,nres-1
16591         ind=ind+1
16592 !         ind=indmat(i,j)
16593 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16594        do k=1,3
16595        gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
16596         enddo
16597         do k=1,3
16598         gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
16599          enddo
16600        enddo
16601       do j=i+1,nres-1
16602         ind1=ind1+1
16603 !         ind1=indmat(i,j)
16604 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
16605         do k=1,3
16606           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
16607           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
16608           enddo
16609         enddo
16610       if (i.gt.1) g(i-1)=gphii
16611       if (n.gt.nphi) g(nphi+i)=gthetai
16612       enddo
16613       if (n.le.nphi+ntheta) goto 10
16614       do i=2,nres-1
16615       if (itype(i,1).ne.10) then
16616           galphai=0.0D0
16617         gomegai=0.0D0
16618         do k=1,3
16619           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
16620           enddo
16621         do k=1,3
16622           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
16623           enddo
16624           g(ialph(i,1))=galphai
16625         g(ialph(i,1)+nside)=gomegai
16626         endif
16627       enddo
16628 !
16629 ! Add the components corresponding to local energy terms.
16630 !
16631    10 continue
16632       do i=1,nvar
16633 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
16634         g(i)=g(i)+gloc(i,icg)
16635       enddo
16636 ! Uncomment following three lines for diagnostics.
16637 !d    call intout
16638 !elwrite(iout,*) "in gradient after calling intout"
16639 !d    call briefout(0,0.0d0)
16640 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
16641       return
16642       end subroutine gradient
16643 !-----------------------------------------------------------------------------
16644       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
16645
16646       use comm_chu
16647 !      implicit real*8 (a-h,o-z)
16648 !      include 'DIMENSIONS'
16649 !      include 'COMMON.DERIV'
16650 !      include 'COMMON.IOUNITS'
16651 !      include 'COMMON.GEO'
16652       integer :: n,nf
16653 !el      integer :: jjj
16654 !el      common /chuju/ jjj
16655       real(kind=8) :: energia(0:n_ene)
16656       integer :: uiparm(1)
16657       real(kind=8) :: urparm(1)
16658       real(kind=8) :: f
16659       real(kind=8),external :: ufparm
16660       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
16661 !     if (jjj.gt.0) then
16662 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16663 !     endif
16664       nfl=nf
16665       icg=mod(nf,2)+1
16666 !d      print *,'func',nf,nfl,icg
16667       call var_to_geom(n,x)
16668       call zerograd
16669       call chainbuild
16670 !d    write (iout,*) 'ETOTAL called from FUNC'
16671       call etotal(energia)
16672       call sum_gradient
16673       f=energia(0)
16674 !     if (jjj.gt.0) then
16675 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16676 !       write (iout,*) 'f=',etot
16677 !       jjj=0
16678 !     endif
16679       return
16680       end subroutine func
16681 !-----------------------------------------------------------------------------
16682       subroutine cartgrad
16683 !      implicit real*8 (a-h,o-z)
16684 !      include 'DIMENSIONS'
16685       use energy_data
16686       use MD_data, only: totT,usampl,eq_time
16687 #ifdef MPI
16688       include 'mpif.h'
16689 #endif
16690 !      include 'COMMON.CHAIN'
16691 !      include 'COMMON.DERIV'
16692 !      include 'COMMON.VAR'
16693 !      include 'COMMON.INTERACT'
16694 !      include 'COMMON.FFIELD'
16695 !      include 'COMMON.MD'
16696 !      include 'COMMON.IOUNITS'
16697 !      include 'COMMON.TIME1'
16698 !
16699       integer :: i,j
16700       real(kind=8) :: time00,time01
16701
16702 ! This subrouting calculates total Cartesian coordinate gradient.
16703 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
16704 !
16705 !#define DEBUG
16706 #ifdef TIMINGtime01
16707       time00=MPI_Wtime()
16708 #endif
16709       icg=1
16710       call sum_gradient
16711 #ifdef TIMING
16712 #endif
16713 !#define DEBUG
16714 !el      write (iout,*) "After sum_gradient"
16715 #ifdef DEBUG
16716       write (iout,*) "After sum_gradient"
16717       do i=1,nres-1
16718         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
16719         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
16720       enddo
16721 #endif
16722 !#undef DEBUG
16723 ! If performing constraint dynamics, add the gradients of the constraint energy
16724       if(usampl.and.totT.gt.eq_time) then
16725          do i=1,nct
16726            do j=1,3
16727              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
16728              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
16729            enddo
16730          enddo
16731          do i=1,nres-3
16732            gloc(i,icg)=gloc(i,icg)+dugamma(i)
16733          enddo
16734          do i=1,nres-2
16735            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
16736          enddo
16737       endif
16738 !elwrite (iout,*) "After sum_gradient"
16739 #ifdef TIMING
16740       time01=MPI_Wtime()
16741 #endif
16742       call intcartderiv
16743 !elwrite (iout,*) "After sum_gradient"
16744 #ifdef TIMING
16745       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
16746 #endif
16747 !     call checkintcartgrad
16748 !     write(iout,*) 'calling int_to_cart'
16749 !#define DEBUG
16750 #ifdef DEBUG
16751       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
16752 #endif
16753       do i=0,nct
16754         do j=1,3
16755           gcart(j,i)=gradc(j,i,icg)
16756           gxcart(j,i)=gradx(j,i,icg)
16757 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
16758         enddo
16759 #ifdef DEBUG
16760         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
16761           (gxcart(j,i),j=1,3),gloc(i,icg)
16762 #endif
16763       enddo
16764 #ifdef TIMING
16765       time01=MPI_Wtime()
16766 #endif
16767 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16768       call int_to_cart
16769 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16770
16771 #ifdef TIMING
16772             time_inttocart=time_inttocart+MPI_Wtime()-time01
16773 #endif
16774 #ifdef DEBUG
16775             write (iout,*) "gcart and gxcart after int_to_cart"
16776             do i=0,nres-1
16777             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
16778             (gxcart(j,i),j=1,3)
16779             enddo
16780 #endif
16781 !#undef DEBUG
16782 #ifdef CARGRAD
16783 #ifdef DEBUG
16784             write (iout,*) "CARGRAD"
16785 #endif
16786             do i=nres,0,-1
16787             do j=1,3
16788               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16789       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16790             enddo
16791       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
16792       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
16793             enddo
16794       ! Correction: dummy residues
16795             if (nnt.gt.1) then
16796               do j=1,3
16797       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
16798             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
16799             enddo
16800           endif
16801           if (nct.lt.nres) then
16802             do j=1,3
16803       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
16804             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
16805             enddo
16806           endif
16807 #endif
16808 #ifdef TIMING
16809           time_cartgrad=time_cartgrad+MPI_Wtime()-time00
16810 #endif
16811 !#undef DEBUG
16812           return
16813           end subroutine cartgrad
16814       !-----------------------------------------------------------------------------
16815           subroutine zerograd
16816       !      implicit real*8 (a-h,o-z)
16817       !      include 'DIMENSIONS'
16818       !      include 'COMMON.DERIV'
16819       !      include 'COMMON.CHAIN'
16820       !      include 'COMMON.VAR'
16821       !      include 'COMMON.MD'
16822       !      include 'COMMON.SCCOR'
16823       !
16824       !el local variables
16825           integer :: i,j,intertyp,k
16826       ! Initialize Cartesian-coordinate gradient
16827       !
16828       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
16829       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
16830
16831       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
16832       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
16833       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
16834       !      allocate(gradcorr_long(3,nres))
16835       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
16836       !      allocate(gcorr6_turn_long(3,nres))
16837       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
16838
16839       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
16840
16841       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
16842       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
16843
16844       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
16845       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
16846
16847       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
16848       !      allocate(gscloc(3,nres)) !(3,maxres)
16849       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
16850
16851
16852
16853       !      common /deriv_scloc/
16854       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
16855       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
16856       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
16857       !      common /mpgrad/
16858       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
16859
16860
16861
16862       !          gradc(j,i,icg)=0.0d0
16863       !          gradx(j,i,icg)=0.0d0
16864
16865       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
16866       !elwrite(iout,*) "icg",icg
16867           do i=-1,nres
16868           do j=1,3
16869             gvdwx(j,i)=0.0D0
16870             gradx_scp(j,i)=0.0D0
16871             gvdwc(j,i)=0.0D0
16872             gvdwc_scp(j,i)=0.0D0
16873             gvdwc_scpp(j,i)=0.0d0
16874             gelc(j,i)=0.0D0
16875             gelc_long(j,i)=0.0D0
16876             gradb(j,i)=0.0d0
16877             gradbx(j,i)=0.0d0
16878             gvdwpp(j,i)=0.0d0
16879             gel_loc(j,i)=0.0d0
16880             gel_loc_long(j,i)=0.0d0
16881             ghpbc(j,i)=0.0D0
16882             ghpbx(j,i)=0.0D0
16883             gcorr3_turn(j,i)=0.0d0
16884             gcorr4_turn(j,i)=0.0d0
16885             gradcorr(j,i)=0.0d0
16886             gradcorr_long(j,i)=0.0d0
16887             gradcorr5_long(j,i)=0.0d0
16888             gradcorr6_long(j,i)=0.0d0
16889             gcorr6_turn_long(j,i)=0.0d0
16890             gradcorr5(j,i)=0.0d0
16891             gradcorr6(j,i)=0.0d0
16892             gcorr6_turn(j,i)=0.0d0
16893             gsccorc(j,i)=0.0d0
16894             gsccorx(j,i)=0.0d0
16895             gradc(j,i,icg)=0.0d0
16896             gradx(j,i,icg)=0.0d0
16897             gscloc(j,i)=0.0d0
16898             gsclocx(j,i)=0.0d0
16899             gliptran(j,i)=0.0d0
16900             gliptranx(j,i)=0.0d0
16901             gliptranc(j,i)=0.0d0
16902             gshieldx(j,i)=0.0d0
16903             gshieldc(j,i)=0.0d0
16904             gshieldc_loc(j,i)=0.0d0
16905             gshieldx_ec(j,i)=0.0d0
16906             gshieldc_ec(j,i)=0.0d0
16907             gshieldc_loc_ec(j,i)=0.0d0
16908             gshieldx_t3(j,i)=0.0d0
16909             gshieldc_t3(j,i)=0.0d0
16910             gshieldc_loc_t3(j,i)=0.0d0
16911             gshieldx_t4(j,i)=0.0d0
16912             gshieldc_t4(j,i)=0.0d0
16913             gshieldc_loc_t4(j,i)=0.0d0
16914             gshieldx_ll(j,i)=0.0d0
16915             gshieldc_ll(j,i)=0.0d0
16916             gshieldc_loc_ll(j,i)=0.0d0
16917             gg_tube(j,i)=0.0d0
16918             gg_tube_sc(j,i)=0.0d0
16919             gradafm(j,i)=0.0d0
16920             gradb_nucl(j,i)=0.0d0
16921             gradbx_nucl(j,i)=0.0d0
16922             gvdwpp_nucl(j,i)=0.0d0
16923             gvdwpp(j,i)=0.0d0
16924             gelpp(j,i)=0.0d0
16925             gvdwpsb(j,i)=0.0d0
16926             gvdwpsb1(j,i)=0.0d0
16927             gvdwsbc(j,i)=0.0d0
16928             gvdwsbx(j,i)=0.0d0
16929             gelsbc(j,i)=0.0d0
16930             gradcorr_nucl(j,i)=0.0d0
16931             gradcorr3_nucl(j,i)=0.0d0
16932             gradxorr_nucl(j,i)=0.0d0
16933             gradxorr3_nucl(j,i)=0.0d0
16934             gelsbx(j,i)=0.0d0
16935             gsbloc(j,i)=0.0d0
16936             gsblocx(j,i)=0.0d0
16937             gradpepcat(j,i)=0.0d0
16938             gradpepcatx(j,i)=0.0d0
16939             gradcatcat(j,i)=0.0d0
16940             gvdwx_scbase(j,i)=0.0d0
16941             gvdwc_scbase(j,i)=0.0d0
16942             gvdwx_pepbase(j,i)=0.0d0
16943             gvdwc_pepbase(j,i)=0.0d0
16944             gvdwx_scpho(j,i)=0.0d0
16945             gvdwc_scpho(j,i)=0.0d0
16946             gvdwc_peppho(j,i)=0.0d0
16947             gradnuclcatx(j,i)=0.0d0
16948             gradnuclcat(j,i)=0.0d0
16949           enddo
16950            enddo
16951           do i=0,nres
16952           do j=1,3
16953             do intertyp=1,3
16954              gloc_sc(intertyp,i,icg)=0.0d0
16955             enddo
16956           enddo
16957           enddo
16958           do i=1,nres
16959            do j=1,maxcontsshi
16960            shield_list(j,i)=0
16961           do k=1,3
16962       !C           print *,i,j,k
16963              grad_shield_side(k,j,i)=0.0d0
16964              grad_shield_loc(k,j,i)=0.0d0
16965            enddo
16966            enddo
16967            ishield_list(i)=0
16968           enddo
16969
16970       !
16971       ! Initialize the gradient of local energy terms.
16972       !
16973       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
16974       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
16975       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
16976       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
16977       !      allocate(gel_loc_turn3(nres))
16978       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
16979       !      allocate(gsccor_loc(nres))      !(maxres)
16980
16981           do i=1,4*nres
16982           gloc(i,icg)=0.0D0
16983           enddo
16984           do i=1,nres
16985           gel_loc_loc(i)=0.0d0
16986           gcorr_loc(i)=0.0d0
16987           g_corr5_loc(i)=0.0d0
16988           g_corr6_loc(i)=0.0d0
16989           gel_loc_turn3(i)=0.0d0
16990           gel_loc_turn4(i)=0.0d0
16991           gel_loc_turn6(i)=0.0d0
16992           gsccor_loc(i)=0.0d0
16993           enddo
16994       ! initialize gcart and gxcart
16995       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
16996           do i=0,nres
16997           do j=1,3
16998             gcart(j,i)=0.0d0
16999             gxcart(j,i)=0.0d0
17000           enddo
17001           enddo
17002           return
17003           end subroutine zerograd
17004       !-----------------------------------------------------------------------------
17005           real(kind=8) function fdum()
17006           fdum=0.0D0
17007           return
17008           end function fdum
17009       !-----------------------------------------------------------------------------
17010       ! intcartderiv.F
17011       !-----------------------------------------------------------------------------
17012           subroutine intcartderiv
17013       !      implicit real*8 (a-h,o-z)
17014       !      include 'DIMENSIONS'
17015 #ifdef MPI
17016           include 'mpif.h'
17017 #endif
17018       !      include 'COMMON.SETUP'
17019       !      include 'COMMON.CHAIN'
17020       !      include 'COMMON.VAR'
17021       !      include 'COMMON.GEO'
17022       !      include 'COMMON.INTERACT'
17023       !      include 'COMMON.DERIV'
17024       !      include 'COMMON.IOUNITS'
17025       !      include 'COMMON.LOCAL'
17026       !      include 'COMMON.SCCOR'
17027           real(kind=8) :: pi4,pi34
17028           real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
17029           real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
17030                   dcosomega,dsinomega !(3,3,maxres)
17031           real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
17032
17033           integer :: i,j,k
17034           real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
17035                 fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
17036                 fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
17037                 fac17,coso_inv,fac10,fac11,fac12,fac13,fac14,IERROR
17038           integer :: nres2
17039           nres2=2*nres
17040
17041       !el from module energy-------------
17042       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
17043       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
17044       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
17045
17046       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
17047       !el      allocate(dsintau(3,3,3,0:nres2))
17048       !el      allocate(dtauangle(3,3,3,0:nres2))
17049       !el      allocate(domicron(3,2,2,0:nres2))
17050       !el      allocate(dcosomicron(3,2,2,0:nres2))
17051
17052
17053
17054 #if defined(MPI) && defined(PARINTDER)
17055           if (nfgtasks.gt.1 .and. me.eq.king) &
17056           call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
17057 #endif
17058           pi4 = 0.5d0*pipol
17059           pi34 = 3*pi4
17060
17061       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
17062       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
17063
17064       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
17065           do i=1,nres
17066           do j=1,3
17067             dtheta(j,1,i)=0.0d0
17068             dtheta(j,2,i)=0.0d0
17069             dphi(j,1,i)=0.0d0
17070             dphi(j,2,i)=0.0d0
17071             dphi(j,3,i)=0.0d0
17072             dcosomicron(j,1,1,i)=0.0d0
17073             dcosomicron(j,1,2,i)=0.0d0
17074             dcosomicron(j,2,1,i)=0.0d0
17075             dcosomicron(j,2,2,i)=0.0d0
17076           enddo
17077           enddo
17078       ! Derivatives of theta's
17079 #if defined(MPI) && defined(PARINTDER)
17080       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17081           do i=max0(ithet_start-1,3),ithet_end
17082 #else
17083           do i=3,nres
17084 #endif
17085           cost=dcos(theta(i))
17086           sint=sqrt(1-cost*cost)
17087           do j=1,3
17088             dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
17089             vbld(i-1)
17090             if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
17091             dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
17092             vbld(i)
17093             if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
17094           enddo
17095           enddo
17096 #if defined(MPI) && defined(PARINTDER)
17097       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17098           do i=max0(ithet_start-1,3),ithet_end
17099 #else
17100           do i=3,nres
17101 #endif
17102           if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1).and.molnum(i).ne.5) then
17103           cost1=dcos(omicron(1,i))
17104           sint1=sqrt(1-cost1*cost1)
17105           cost2=dcos(omicron(2,i))
17106           sint2=sqrt(1-cost2*cost2)
17107            do j=1,3
17108       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
17109             dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
17110             cost1*dc_norm(j,i-2))/ &
17111             vbld(i-1)
17112             domicron(j,1,1,i)=-1.0/sint1*dcosomicron(j,1,1,i)
17113             dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
17114             +cost1*(dc_norm(j,i-1+nres)))/ &
17115             vbld(i-1+nres)
17116             domicron(j,1,2,i)=-1.0/sint1*dcosomicron(j,1,2,i)
17117       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
17118       !C Looks messy but better than if in loop
17119             dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
17120             +cost2*dc_norm(j,i-1))/ &
17121             vbld(i)
17122             domicron(j,2,1,i)=-1.0/sint2*dcosomicron(j,2,1,i)
17123             dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
17124              +cost2*(-dc_norm(j,i-1+nres)))/ &
17125             vbld(i-1+nres)
17126       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
17127             domicron(j,2,2,i)=-1.0/sint2*dcosomicron(j,2,2,i)
17128           enddo
17129            endif
17130           enddo
17131       !elwrite(iout,*) "after vbld write"
17132       ! Derivatives of phi:
17133       ! If phi is 0 or 180 degrees, then the formulas
17134       ! have to be derived by power series expansion of the
17135       ! conventional formulas around 0 and 180.
17136 #ifdef PARINTDER
17137           do i=iphi1_start,iphi1_end
17138 #else
17139           do i=4,nres
17140 #endif
17141       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
17142       ! the conventional case
17143           sint=dsin(theta(i))
17144           sint1=dsin(theta(i-1))
17145           sing=dsin(phi(i))
17146           cost=dcos(theta(i))
17147           cost1=dcos(theta(i-1))
17148           cosg=dcos(phi(i))
17149           scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
17150           fac0=1.0d0/(sint1*sint)
17151           fac1=cost*fac0
17152           fac2=cost1*fac0
17153           fac3=cosg*cost1/(sint1*sint1)
17154           fac4=cosg*cost/(sint*sint)
17155       !    Obtaining the gamma derivatives from sine derivative
17156            if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
17157              phi(i).gt.pi34.and.phi(i).le.pi.or. &
17158              phi(i).ge.-pi.and.phi(i).le.-pi34) then
17159            call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17160            call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
17161            call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17162            do j=1,3
17163             ctgt=cost/sint
17164             ctgt1=cost1/sint1
17165             cosg_inv=1.0d0/cosg
17166             if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17167             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17168               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
17169             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
17170             dsinphi(j,2,i)= &
17171               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
17172               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17173             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
17174             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
17175               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17176       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17177             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
17178             endif
17179       ! Bug fixed 3/24/05 (AL)
17180            enddo
17181       !   Obtaining the gamma derivatives from cosine derivative
17182           else
17183              do j=1,3
17184              if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17185              dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17186              dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17187              dc_norm(j,i-3))/vbld(i-2)
17188              dphi(j,1,i)=-1.0/sing*dcosphi(j,1,i)
17189              dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17190              dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17191              dcostheta(j,1,i)
17192              dphi(j,2,i)=-1.0/sing*dcosphi(j,2,i)
17193              dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17194              dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17195              dc_norm(j,i-1))/vbld(i)
17196              dphi(j,3,i)=-1.0/sing*dcosphi(j,3,i)
17197 !#define DEBUG
17198 #ifdef DEBUG
17199              write(iout,*) "just after",dphi(j,3,i),sing,dcosphi(j,3,i)
17200 #endif
17201 !#undef DEBUG
17202              endif
17203            enddo
17204           endif
17205           enddo
17206       !alculate derivative of Tauangle
17207 #ifdef PARINTDER
17208           do i=itau_start,itau_end
17209 #else
17210           do i=3,nres
17211       !elwrite(iout,*) " vecpr",i,nres
17212 #endif
17213            if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17214       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
17215       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
17216       !c dtauangle(j,intertyp,dervityp,residue number)
17217       !c INTERTYP=1 SC...Ca...Ca..Ca
17218       ! the conventional case
17219           sint=dsin(theta(i))
17220           sint1=dsin(omicron(2,i-1))
17221           sing=dsin(tauangle(1,i))
17222           cost=dcos(theta(i))
17223           cost1=dcos(omicron(2,i-1))
17224           cosg=dcos(tauangle(1,i))
17225       !elwrite(iout,*) " vecpr5",i,nres
17226           do j=1,3
17227       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
17228       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
17229           dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17230       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
17231           enddo
17232           scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
17233           fac0=1.0d0/(sint1*sint)
17234           fac1=cost*fac0
17235           fac2=cost1*fac0
17236           fac3=cosg*cost1/(sint1*sint1)
17237           fac4=cosg*cost/(sint*sint)
17238       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
17239       !    Obtaining the gamma derivatives from sine derivative
17240            if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
17241              tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
17242              tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
17243            call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17244            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
17245            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17246           do j=1,3
17247             ctgt=cost/sint
17248             ctgt1=cost1/sint1
17249             cosg_inv=1.0d0/cosg
17250             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17251            -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
17252            *vbld_inv(i-2+nres)
17253             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
17254             dsintau(j,1,2,i)= &
17255               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
17256               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17257       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
17258             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
17259       ! Bug fixed 3/24/05 (AL)
17260             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
17261               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17262       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17263             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
17264            enddo
17265       !   Obtaining the gamma derivatives from cosine derivative
17266           else
17267              do j=1,3
17268              dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17269              dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17270              (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
17271              dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
17272              dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17273              dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17274              dcostheta(j,1,i)
17275              dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
17276              dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17277              dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
17278              dc_norm(j,i-1))/vbld(i)
17279              dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
17280       !         write (iout,*) "else",i
17281            enddo
17282           endif
17283       !        do k=1,3
17284       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
17285       !        enddo
17286           enddo
17287       !C Second case Ca...Ca...Ca...SC
17288 #ifdef PARINTDER
17289           do i=itau_start,itau_end
17290 #else
17291           do i=4,nres
17292 #endif
17293            if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17294             (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
17295       ! the conventional case
17296           sint=dsin(omicron(1,i))
17297           sint1=dsin(theta(i-1))
17298           sing=dsin(tauangle(2,i))
17299           cost=dcos(omicron(1,i))
17300           cost1=dcos(theta(i-1))
17301           cosg=dcos(tauangle(2,i))
17302       !        do j=1,3
17303       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17304       !        enddo
17305           scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
17306           fac0=1.0d0/(sint1*sint)
17307           fac1=cost*fac0
17308           fac2=cost1*fac0
17309           fac3=cosg*cost1/(sint1*sint1)
17310           fac4=cosg*cost/(sint*sint)
17311       !    Obtaining the gamma derivatives from sine derivative
17312            if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
17313              tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
17314              tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
17315            call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
17316            call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
17317            call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17318           do j=1,3
17319             ctgt=cost/sint
17320             ctgt1=cost1/sint1
17321             cosg_inv=1.0d0/cosg
17322             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17323               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
17324       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
17325       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
17326             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
17327             dsintau(j,2,2,i)= &
17328               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
17329               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17330       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
17331       !     & sing*ctgt*domicron(j,1,2,i),
17332       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17333             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
17334       ! Bug fixed 3/24/05 (AL)
17335             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17336              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
17337       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17338             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
17339            enddo
17340       !   Obtaining the gamma derivatives from cosine derivative
17341           else
17342              do j=1,3
17343              dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17344              dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17345              dc_norm(j,i-3))/vbld(i-2)
17346              dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
17347              dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17348              dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17349              dcosomicron(j,1,1,i)
17350              dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
17351              dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17352              dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17353              dc_norm(j,i-1+nres))/vbld(i-1+nres)
17354              dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
17355       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
17356            enddo
17357           endif
17358           enddo
17359
17360       !CC third case SC...Ca...Ca...SC
17361 #ifdef PARINTDER
17362
17363           do i=itau_start,itau_end
17364 #else
17365           do i=3,nres
17366 #endif
17367       ! the conventional case
17368           if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17369           (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17370           sint=dsin(omicron(1,i))
17371           sint1=dsin(omicron(2,i-1))
17372           sing=dsin(tauangle(3,i))
17373           cost=dcos(omicron(1,i))
17374           cost1=dcos(omicron(2,i-1))
17375           cosg=dcos(tauangle(3,i))
17376           do j=1,3
17377           dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17378       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17379           enddo
17380           scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
17381           fac0=1.0d0/(sint1*sint)
17382           fac1=cost*fac0
17383           fac2=cost1*fac0
17384           fac3=cosg*cost1/(sint1*sint1)
17385           fac4=cosg*cost/(sint*sint)
17386       !    Obtaining the gamma derivatives from sine derivative
17387            if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
17388              tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
17389              tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
17390            call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
17391            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
17392            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17393           do j=1,3
17394             ctgt=cost/sint
17395             ctgt1=cost1/sint1
17396             cosg_inv=1.0d0/cosg
17397             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17398               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
17399               *vbld_inv(i-2+nres)
17400             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
17401             dsintau(j,3,2,i)= &
17402               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
17403               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17404             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
17405       ! Bug fixed 3/24/05 (AL)
17406             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17407               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
17408               *vbld_inv(i-1+nres)
17409       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17410             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
17411            enddo
17412       !   Obtaining the gamma derivatives from cosine derivative
17413           else
17414              do j=1,3
17415              dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17416              dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17417              dc_norm2(j,i-2+nres))/vbld(i-2+nres)
17418              dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
17419              dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17420              dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17421              dcosomicron(j,1,1,i)
17422              dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
17423              dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17424              dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
17425              dc_norm(j,i-1+nres))/vbld(i-1+nres)
17426              dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
17427       !          write(iout,*) "else",i
17428            enddo
17429           endif
17430           enddo
17431
17432 #ifdef CRYST_SC
17433       !   Derivatives of side-chain angles alpha and omega
17434 #if defined(MPI) && defined(PARINTDER)
17435           do i=ibond_start,ibond_end
17436 #else
17437           do i=2,nres-1
17438 #endif
17439             if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
17440              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
17441              fac6=fac5/vbld(i)
17442              fac7=fac5*fac5
17443              fac8=fac5/vbld(i+1)
17444              fac9=fac5/vbld(i+nres)
17445              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
17446              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
17447              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
17448              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
17449              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
17450              sina=sqrt(1-cosa*cosa)
17451              sino=dsin(omeg(i))
17452       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
17453              do j=1,3
17454               dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
17455               dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
17456               dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
17457               dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
17458               scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
17459               dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
17460               dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
17461               dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
17462               vbld(i+nres))
17463               dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
17464             enddo
17465       ! obtaining the derivatives of omega from sines
17466             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
17467                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
17468                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
17469                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
17470                dsin(theta(i+1)))
17471                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
17472                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
17473                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
17474                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
17475                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
17476                coso_inv=1.0d0/dcos(omeg(i))
17477                do j=1,3
17478                dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
17479                +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
17480                (sino*dc_norm(j,i-1))/vbld(i)
17481                domega(j,1,i)=coso_inv*dsinomega(j,1,i)
17482                dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
17483                +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
17484                -sino*dc_norm(j,i)/vbld(i+1)
17485                domega(j,2,i)=coso_inv*dsinomega(j,2,i)
17486                dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
17487                fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
17488                vbld(i+nres)
17489                domega(j,3,i)=coso_inv*dsinomega(j,3,i)
17490               enddo
17491              else
17492       !   obtaining the derivatives of omega from cosines
17493              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
17494              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
17495              fac12=fac10*sina
17496              fac13=fac12*fac12
17497              fac14=sina*sina
17498              do j=1,3
17499               dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
17500               dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
17501               (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
17502               fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
17503               domega(j,1,i)=-1/sino*dcosomega(j,1,i)
17504               dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
17505               dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
17506               dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
17507               (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
17508               dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
17509               domega(j,2,i)=-1/sino*dcosomega(j,2,i)
17510               dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
17511               scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
17512               (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
17513               domega(j,3,i)=-1/sino*dcosomega(j,3,i)
17514             enddo
17515             endif
17516            else
17517              do j=1,3
17518              do k=1,3
17519                dalpha(k,j,i)=0.0d0
17520                domega(k,j,i)=0.0d0
17521              enddo
17522              enddo
17523            endif
17524            enddo
17525 #endif
17526 #if defined(MPI) && defined(PARINTDER)
17527           if (nfgtasks.gt.1) then
17528 #ifdef DEBUG
17529       !d      write (iout,*) "Gather dtheta"
17530       !d      call flush(iout)
17531           write (iout,*) "dtheta before gather"
17532           do i=1,nres
17533           write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
17534           enddo
17535 #endif
17536           call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
17537           MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
17538           king,FG_COMM,IERROR)
17539 !#define DEBUG
17540 #ifdef DEBUG
17541       !d      write (iout,*) "Gather dphi"
17542       !d      call flush(iout)
17543           write (iout,*) "dphi before gather"
17544           do i=1,nres
17545           write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
17546           enddo
17547 #endif
17548 !#undef DEBUG
17549           call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
17550           MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
17551           king,FG_COMM,IERROR)
17552       !d      write (iout,*) "Gather dalpha"
17553       !d      call flush(iout)
17554 #ifdef CRYST_SC
17555           call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
17556           MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17557           king,FG_COMM,IERROR)
17558       !d      write (iout,*) "Gather domega"
17559       !d      call flush(iout)
17560           call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
17561           MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17562           king,FG_COMM,IERROR)
17563 #endif
17564           endif
17565 #endif
17566 !#define DEBUG
17567 #ifdef DEBUG
17568           write (iout,*) "dtheta after gather"
17569           do i=1,nres
17570           write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
17571           enddo
17572           write (iout,*) "dphi after gather"
17573           do i=1,nres
17574           write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
17575           enddo
17576           write (iout,*) "dalpha after gather"
17577           do i=1,nres
17578           write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
17579           enddo
17580           write (iout,*) "domega after gather"
17581           do i=1,nres
17582           write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
17583           enddo
17584 #endif
17585 !#undef DEBUG
17586           return
17587           end subroutine intcartderiv
17588       !-----------------------------------------------------------------------------
17589           subroutine checkintcartgrad
17590       !      implicit real*8 (a-h,o-z)
17591       !      include 'DIMENSIONS'
17592 #ifdef MPI
17593           include 'mpif.h'
17594 #endif
17595       !      include 'COMMON.CHAIN'
17596       !      include 'COMMON.VAR'
17597       !      include 'COMMON.GEO'
17598       !      include 'COMMON.INTERACT'
17599       !      include 'COMMON.DERIV'
17600       !      include 'COMMON.IOUNITS'
17601       !      include 'COMMON.SETUP'
17602           real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
17603           real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
17604           real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
17605           real(kind=8),dimension(3) :: dc_norm_s
17606           real(kind=8) :: aincr=1.0d-5
17607           integer :: i,j
17608           real(kind=8) :: dcji
17609           do i=1,nres
17610           phi_s(i)=phi(i)
17611           theta_s(i)=theta(i)
17612           alph_s(i)=alph(i)
17613           omeg_s(i)=omeg(i)
17614           enddo
17615       ! Check theta gradient
17616           write (iout,*) &
17617            "Analytical (upper) and numerical (lower) gradient of theta"
17618           write (iout,*)
17619           do i=3,nres
17620           do j=1,3
17621             dcji=dc(j,i-2)
17622             dc(j,i-2)=dcji+aincr
17623             call chainbuild_cart
17624             call int_from_cart1(.false.)
17625         dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
17626         dc(j,i-2)=dcji
17627         dcji=dc(j,i-1)
17628         dc(j,i-1)=dc(j,i-1)+aincr
17629         call chainbuild_cart
17630         dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
17631         dc(j,i-1)=dcji
17632       enddo
17633 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
17634 !el          (dtheta(j,2,i),j=1,3)
17635 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
17636 !el          (dthetanum(j,2,i),j=1,3)
17637 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
17638 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
17639 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
17640 !el        write (iout,*)
17641       enddo
17642 ! Check gamma gradient
17643       write (iout,*) &
17644        "Analytical (upper) and numerical (lower) gradient of gamma"
17645       do i=4,nres
17646       do j=1,3
17647         dcji=dc(j,i-3)
17648         dc(j,i-3)=dcji+aincr
17649         call chainbuild_cart
17650         dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
17651             dc(j,i-3)=dcji
17652         dcji=dc(j,i-2)
17653         dc(j,i-2)=dcji+aincr
17654         call chainbuild_cart
17655         dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
17656         dc(j,i-2)=dcji
17657         dcji=dc(j,i-1)
17658         dc(j,i-1)=dc(j,i-1)+aincr
17659         call chainbuild_cart
17660         dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
17661         dc(j,i-1)=dcji
17662       enddo
17663 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
17664 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
17665 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
17666 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
17667 !el        write (iout,'(5x,3(3f10.5,5x))') &
17668 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
17669 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
17670 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
17671 !el        write (iout,*)
17672       enddo
17673 ! Check alpha gradient
17674       write (iout,*) &
17675        "Analytical (upper) and numerical (lower) gradient of alpha"
17676       do i=2,nres-1
17677        if(itype(i,1).ne.10) then
17678              do j=1,3
17679               dcji=dc(j,i-1)
17680                dc(j,i-1)=dcji+aincr
17681             call chainbuild_cart
17682             dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
17683              /aincr
17684               dc(j,i-1)=dcji
17685             dcji=dc(j,i)
17686             dc(j,i)=dcji+aincr
17687             call chainbuild_cart
17688             dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
17689              /aincr
17690             dc(j,i)=dcji
17691             dcji=dc(j,i+nres)
17692             dc(j,i+nres)=dc(j,i+nres)+aincr
17693             call chainbuild_cart
17694             dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
17695              /aincr
17696            dc(j,i+nres)=dcji
17697           enddo
17698         endif
17699 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
17700 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
17701 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
17702 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
17703 !el        write (iout,'(5x,3(3f10.5,5x))') &
17704 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
17705 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
17706 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
17707 !el        write (iout,*)
17708       enddo
17709 !     Check omega gradient
17710       write (iout,*) &
17711        "Analytical (upper) and numerical (lower) gradient of omega"
17712       do i=2,nres-1
17713        if(itype(i,1).ne.10) then
17714              do j=1,3
17715               dcji=dc(j,i-1)
17716                dc(j,i-1)=dcji+aincr
17717             call chainbuild_cart
17718             domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
17719              /aincr
17720               dc(j,i-1)=dcji
17721             dcji=dc(j,i)
17722             dc(j,i)=dcji+aincr
17723             call chainbuild_cart
17724             domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
17725              /aincr
17726             dc(j,i)=dcji
17727             dcji=dc(j,i+nres)
17728             dc(j,i+nres)=dc(j,i+nres)+aincr
17729             call chainbuild_cart
17730             domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
17731              /aincr
17732            dc(j,i+nres)=dcji
17733           enddo
17734         endif
17735 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
17736 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
17737 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
17738 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
17739 !el        write (iout,'(5x,3(3f10.5,5x))') &
17740 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
17741 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
17742 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
17743 !el        write (iout,*)
17744       enddo
17745       return
17746       end subroutine checkintcartgrad
17747 !-----------------------------------------------------------------------------
17748 ! q_measure.F
17749 !-----------------------------------------------------------------------------
17750       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
17751 !      implicit real*8 (a-h,o-z)
17752 !      include 'DIMENSIONS'
17753 !      include 'COMMON.IOUNITS'
17754 !      include 'COMMON.CHAIN'
17755 !      include 'COMMON.INTERACT'
17756 !      include 'COMMON.VAR'
17757       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
17758       integer :: kkk,nsep=3
17759       real(kind=8) :: qm      !dist,
17760       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
17761       logical :: lprn=.false.
17762       logical :: flag
17763 !      real(kind=8) :: sigm,x
17764
17765 !el      sigm(x)=0.25d0*x     ! local function
17766       qqmax=1.0d10
17767       do kkk=1,nperm
17768       qq = 0.0d0
17769       nl=0
17770        if(flag) then
17771       do il=seg1+nsep,seg2
17772         do jl=seg1,il-nsep
17773           nl=nl+1
17774           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
17775                    (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
17776                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17777           dij=dist(il,jl)
17778           qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17779           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17780             nl=nl+1
17781             d0ijCM=dsqrt( &
17782                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17783                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17784                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17785             dijCM=dist(il+nres,jl+nres)
17786             qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17787           endif
17788           qq = qq+qqij+qqijCM
17789         enddo
17790       enddo
17791       qq = qq/nl
17792       else
17793       do il=seg1,seg2
17794       if((seg3-il).lt.3) then
17795            secseg=il+3
17796       else
17797            secseg=seg3
17798       endif
17799         do jl=secseg,seg4
17800           nl=nl+1
17801           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17802                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17803                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17804           dij=dist(il,jl)
17805           qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17806           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17807             nl=nl+1
17808             d0ijCM=dsqrt( &
17809                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17810                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17811                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17812             dijCM=dist(il+nres,jl+nres)
17813             qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17814           endif
17815           qq = qq+qqij+qqijCM
17816         enddo
17817       enddo
17818       qq = qq/nl
17819       endif
17820       if (qqmax.le.qq) qqmax=qq
17821       enddo
17822       qwolynes=1.0d0-qqmax
17823       return
17824       end function qwolynes
17825 !-----------------------------------------------------------------------------
17826       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
17827 !      implicit real*8 (a-h,o-z)
17828 !      include 'DIMENSIONS'
17829 !      include 'COMMON.IOUNITS'
17830 !      include 'COMMON.CHAIN'
17831 !      include 'COMMON.INTERACT'
17832 !      include 'COMMON.VAR'
17833 !      include 'COMMON.MD'
17834       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
17835       integer :: nsep=3, kkk
17836 !el      real(kind=8) :: dist
17837       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
17838       logical :: lprn=.false.
17839       logical :: flag
17840       real(kind=8) :: sim,dd0,fac,ddqij
17841 !el      sigm(x)=0.25d0*x           ! local function
17842       do kkk=1,nperm
17843       do i=0,nres
17844       do j=1,3
17845         dqwol(j,i)=0.0d0
17846         dxqwol(j,i)=0.0d0
17847       enddo
17848       enddo
17849       nl=0
17850        if(flag) then
17851       do il=seg1+nsep,seg2
17852         do jl=seg1,il-nsep
17853           nl=nl+1
17854           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17855                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17856                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17857           dij=dist(il,jl)
17858           sim = 1.0d0/sigm(d0ij)
17859           sim = sim*sim
17860           dd0 = dij-d0ij
17861           fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17862         do k=1,3
17863             ddqij = (c(k,il)-c(k,jl))*fac
17864             dqwol(k,il)=dqwol(k,il)+ddqij
17865             dqwol(k,jl)=dqwol(k,jl)-ddqij
17866           enddo
17867
17868           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17869             nl=nl+1
17870             d0ijCM=dsqrt( &
17871                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17872                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17873                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17874             dijCM=dist(il+nres,jl+nres)
17875             sim = 1.0d0/sigm(d0ijCM)
17876             sim = sim*sim
17877             dd0=dijCM-d0ijCM
17878             fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17879             do k=1,3
17880             ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17881             dxqwol(k,il)=dxqwol(k,il)+ddqij
17882             dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17883             enddo
17884           endif
17885         enddo
17886       enddo
17887        else
17888       do il=seg1,seg2
17889       if((seg3-il).lt.3) then
17890            secseg=il+3
17891       else
17892            secseg=seg3
17893       endif
17894         do jl=secseg,seg4
17895           nl=nl+1
17896           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17897                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17898                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17899           dij=dist(il,jl)
17900           sim = 1.0d0/sigm(d0ij)
17901           sim = sim*sim
17902           dd0 = dij-d0ij
17903           fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17904           do k=1,3
17905             ddqij = (c(k,il)-c(k,jl))*fac
17906             dqwol(k,il)=dqwol(k,il)+ddqij
17907             dqwol(k,jl)=dqwol(k,jl)-ddqij
17908           enddo
17909           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17910             nl=nl+1
17911             d0ijCM=dsqrt( &
17912                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17913                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17914                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17915             dijCM=dist(il+nres,jl+nres)
17916             sim = 1.0d0/sigm(d0ijCM)
17917             sim=sim*sim
17918             dd0 = dijCM-d0ijCM
17919             fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17920             do k=1,3
17921              ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17922              dxqwol(k,il)=dxqwol(k,il)+ddqij
17923              dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17924             enddo
17925           endif
17926         enddo
17927       enddo
17928       endif
17929       enddo
17930        do i=0,nres
17931        do j=1,3
17932          dqwol(j,i)=dqwol(j,i)/nl
17933          dxqwol(j,i)=dxqwol(j,i)/nl
17934        enddo
17935        enddo
17936       return
17937       end subroutine qwolynes_prim
17938 !-----------------------------------------------------------------------------
17939       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
17940 !      implicit real*8 (a-h,o-z)
17941 !      include 'DIMENSIONS'
17942 !      include 'COMMON.IOUNITS'
17943 !      include 'COMMON.CHAIN'
17944 !      include 'COMMON.INTERACT'
17945 !      include 'COMMON.VAR'
17946       integer :: seg1,seg2,seg3,seg4
17947       logical :: flag
17948       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
17949       real(kind=8),dimension(3,0:2*nres) :: cdummy
17950       real(kind=8) :: q1,q2
17951       real(kind=8) :: delta=1.0d-10
17952       integer :: i,j
17953
17954       do i=0,nres
17955       do j=1,3
17956         q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17957         cdummy(j,i)=c(j,i)
17958         c(j,i)=c(j,i)+delta
17959         q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17960         qwolan(j,i)=(q2-q1)/delta
17961         c(j,i)=cdummy(j,i)
17962       enddo
17963       enddo
17964       do i=0,nres
17965       do j=1,3
17966         q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17967         cdummy(j,i+nres)=c(j,i+nres)
17968         c(j,i+nres)=c(j,i+nres)+delta
17969         q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17970         qwolxan(j,i)=(q2-q1)/delta
17971         c(j,i+nres)=cdummy(j,i+nres)
17972       enddo
17973       enddo
17974 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
17975 !      do i=0,nct
17976 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
17977 !      enddo
17978 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
17979 !      do i=0,nct
17980 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
17981 !      enddo
17982       return
17983       end subroutine qwol_num
17984 !-----------------------------------------------------------------------------
17985       subroutine EconstrQ
17986 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
17987 !      implicit real*8 (a-h,o-z)
17988 !      include 'DIMENSIONS'
17989 !      include 'COMMON.CONTROL'
17990 !      include 'COMMON.VAR'
17991 !      include 'COMMON.MD'
17992       use MD_data
17993 !#ifndef LANG0
17994 !      include 'COMMON.LANGEVIN'
17995 !#else
17996 !      include 'COMMON.LANGEVIN.lang0'
17997 !#endif
17998 !      include 'COMMON.CHAIN'
17999 !      include 'COMMON.DERIV'
18000 !      include 'COMMON.GEO'
18001 !      include 'COMMON.LOCAL'
18002 !      include 'COMMON.INTERACT'
18003 !      include 'COMMON.IOUNITS'
18004 !      include 'COMMON.NAMES'
18005 !      include 'COMMON.TIME1'
18006       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
18007       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
18008                duconst,duxconst
18009       integer :: kstart,kend,lstart,lend,idummy
18010       real(kind=8) :: delta=1.0d-7
18011       integer :: i,j,k,ii
18012       do i=0,nres
18013        do j=1,3
18014           duconst(j,i)=0.0d0
18015           dudconst(j,i)=0.0d0
18016           duxconst(j,i)=0.0d0
18017           dudxconst(j,i)=0.0d0
18018        enddo
18019       enddo
18020       Uconst=0.0d0
18021       do i=1,nfrag
18022        qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18023          idummy,idummy)
18024        Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
18025 ! Calculating the derivatives of Constraint energy with respect to Q
18026        Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
18027          qinfrag(i,iset))
18028 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
18029 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
18030 !         hmnum=(hm2-hm1)/delta
18031 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
18032 !     &   qinfrag(i,iset))
18033 !         write(iout,*) "harmonicnum frag", hmnum
18034 ! Calculating the derivatives of Q with respect to cartesian coordinates
18035        call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18036         idummy,idummy)
18037 !         write(iout,*) "dqwol "
18038 !         do ii=1,nres
18039 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18040 !         enddo
18041 !         write(iout,*) "dxqwol "
18042 !         do ii=1,nres
18043 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18044 !         enddo
18045 ! Calculating numerical gradients of dU/dQi and dQi/dxi
18046 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
18047 !     &  ,idummy,idummy)
18048 !  The gradients of Uconst in Cs
18049        do ii=0,nres
18050           do j=1,3
18051              duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
18052              dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
18053           enddo
18054        enddo
18055       enddo
18056       do i=1,npair
18057        kstart=ifrag(1,ipair(1,i,iset),iset)
18058        kend=ifrag(2,ipair(1,i,iset),iset)
18059        lstart=ifrag(1,ipair(2,i,iset),iset)
18060        lend=ifrag(2,ipair(2,i,iset),iset)
18061        qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
18062        Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
18063 !  Calculating dU/dQ
18064        Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
18065 !         hm1=harmonic(qpair(i),qinpair(i,iset))
18066 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
18067 !         hmnum=(hm2-hm1)/delta
18068 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
18069 !     &   qinpair(i,iset))
18070 !         write(iout,*) "harmonicnum pair ", hmnum
18071 ! Calculating dQ/dXi
18072        call qwolynes_prim(kstart,kend,.false.,&
18073         lstart,lend)
18074 !         write(iout,*) "dqwol "
18075 !         do ii=1,nres
18076 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18077 !         enddo
18078 !         write(iout,*) "dxqwol "
18079 !         do ii=1,nres
18080 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18081 !        enddo
18082 ! Calculating numerical gradients
18083 !        call qwol_num(kstart,kend,.false.
18084 !     &  ,lstart,lend)
18085 ! The gradients of Uconst in Cs
18086        do ii=0,nres
18087           do j=1,3
18088              duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
18089              dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
18090           enddo
18091        enddo
18092       enddo
18093 !      write(iout,*) "Uconst inside subroutine ", Uconst
18094 ! Transforming the gradients from Cs to dCs for the backbone
18095       do i=0,nres
18096        do j=i+1,nres
18097          do k=1,3
18098            dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
18099          enddo
18100        enddo
18101       enddo
18102 !  Transforming the gradients from Cs to dCs for the side chains
18103       do i=1,nres
18104        do j=1,3
18105          dudxconst(j,i)=duxconst(j,i)
18106        enddo
18107       enddo
18108 !      write(iout,*) "dU/ddc backbone "
18109 !       do ii=0,nres
18110 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
18111 !      enddo
18112 !      write(iout,*) "dU/ddX side chain "
18113 !      do ii=1,nres
18114 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
18115 !      enddo
18116 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
18117 !      call dEconstrQ_num
18118       return
18119       end subroutine EconstrQ
18120 !-----------------------------------------------------------------------------
18121       subroutine dEconstrQ_num
18122 ! Calculating numerical dUconst/ddc and dUconst/ddx
18123 !      implicit real*8 (a-h,o-z)
18124 !      include 'DIMENSIONS'
18125 !      include 'COMMON.CONTROL'
18126 !      include 'COMMON.VAR'
18127 !      include 'COMMON.MD'
18128       use MD_data
18129 !#ifndef LANG0
18130 !      include 'COMMON.LANGEVIN'
18131 !#else
18132 !      include 'COMMON.LANGEVIN.lang0'
18133 !#endif
18134 !      include 'COMMON.CHAIN'
18135 !      include 'COMMON.DERIV'
18136 !      include 'COMMON.GEO'
18137 !      include 'COMMON.LOCAL'
18138 !      include 'COMMON.INTERACT'
18139 !      include 'COMMON.IOUNITS'
18140 !      include 'COMMON.NAMES'
18141 !      include 'COMMON.TIME1'
18142       real(kind=8) :: uzap1,uzap2
18143       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
18144       integer :: kstart,kend,lstart,lend,idummy
18145       real(kind=8) :: delta=1.0d-7
18146 !el local variables
18147       integer :: i,ii,j
18148 !     real(kind=8) ::
18149 !     For the backbone
18150       do i=0,nres-1
18151        do j=1,3
18152           dUcartan(j,i)=0.0d0
18153           cdummy(j,i)=dc(j,i)
18154           dc(j,i)=dc(j,i)+delta
18155           call chainbuild_cart
18156         uzap2=0.0d0
18157           do ii=1,nfrag
18158            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18159             idummy,idummy)
18160              uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18161             qinfrag(ii,iset))
18162           enddo
18163           do ii=1,npair
18164              kstart=ifrag(1,ipair(1,ii,iset),iset)
18165              kend=ifrag(2,ipair(1,ii,iset),iset)
18166              lstart=ifrag(1,ipair(2,ii,iset),iset)
18167              lend=ifrag(2,ipair(2,ii,iset),iset)
18168              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18169              uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18170              qinpair(ii,iset))
18171           enddo
18172           dc(j,i)=cdummy(j,i)
18173           call chainbuild_cart
18174           uzap1=0.0d0
18175            do ii=1,nfrag
18176            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18177             idummy,idummy)
18178              uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18179             qinfrag(ii,iset))
18180           enddo
18181           do ii=1,npair
18182              kstart=ifrag(1,ipair(1,ii,iset),iset)
18183              kend=ifrag(2,ipair(1,ii,iset),iset)
18184              lstart=ifrag(1,ipair(2,ii,iset),iset)
18185              lend=ifrag(2,ipair(2,ii,iset),iset)
18186              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18187              uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18188             qinpair(ii,iset))
18189           enddo
18190           ducartan(j,i)=(uzap2-uzap1)/(delta)
18191        enddo
18192       enddo
18193 ! Calculating numerical gradients for dU/ddx
18194       do i=0,nres-1
18195        duxcartan(j,i)=0.0d0
18196        do j=1,3
18197           cdummy(j,i)=dc(j,i+nres)
18198           dc(j,i+nres)=dc(j,i+nres)+delta
18199           call chainbuild_cart
18200         uzap2=0.0d0
18201           do ii=1,nfrag
18202            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18203             idummy,idummy)
18204              uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18205             qinfrag(ii,iset))
18206           enddo
18207           do ii=1,npair
18208              kstart=ifrag(1,ipair(1,ii,iset),iset)
18209              kend=ifrag(2,ipair(1,ii,iset),iset)
18210              lstart=ifrag(1,ipair(2,ii,iset),iset)
18211              lend=ifrag(2,ipair(2,ii,iset),iset)
18212              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18213              uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18214             qinpair(ii,iset))
18215           enddo
18216           dc(j,i+nres)=cdummy(j,i)
18217           call chainbuild_cart
18218           uzap1=0.0d0
18219            do ii=1,nfrag
18220              qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
18221             ifrag(2,ii,iset),.true.,idummy,idummy)
18222              uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18223             qinfrag(ii,iset))
18224           enddo
18225           do ii=1,npair
18226              kstart=ifrag(1,ipair(1,ii,iset),iset)
18227              kend=ifrag(2,ipair(1,ii,iset),iset)
18228              lstart=ifrag(1,ipair(2,ii,iset),iset)
18229              lend=ifrag(2,ipair(2,ii,iset),iset)
18230              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18231              uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18232             qinpair(ii,iset))
18233           enddo
18234           duxcartan(j,i)=(uzap2-uzap1)/(delta)
18235        enddo
18236       enddo
18237       write(iout,*) "Numerical dUconst/ddc backbone "
18238       do ii=0,nres
18239       write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
18240       enddo
18241 !      write(iout,*) "Numerical dUconst/ddx side-chain "
18242 !      do ii=1,nres
18243 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
18244 !      enddo
18245       return
18246       end subroutine dEconstrQ_num
18247 !-----------------------------------------------------------------------------
18248 ! ssMD.F
18249 !-----------------------------------------------------------------------------
18250       subroutine check_energies
18251
18252 !      use random, only: ran_number
18253
18254 !      implicit none
18255 !     Includes
18256 !      include 'DIMENSIONS'
18257 !      include 'COMMON.CHAIN'
18258 !      include 'COMMON.VAR'
18259 !      include 'COMMON.IOUNITS'
18260 !      include 'COMMON.SBRIDGE'
18261 !      include 'COMMON.LOCAL'
18262 !      include 'COMMON.GEO'
18263
18264 !     External functions
18265 !EL      double precision ran_number
18266 !EL      external ran_number
18267
18268 !     Local variables
18269       integer :: i,j,k,l,lmax,p,pmax
18270       real(kind=8) :: rmin,rmax
18271       real(kind=8) :: eij
18272
18273       real(kind=8) :: d
18274       real(kind=8) :: wi,rij,tj,pj
18275 !      return
18276
18277       i=5
18278       j=14
18279
18280       d=dsc(1)
18281       rmin=2.0D0
18282       rmax=12.0D0
18283
18284       lmax=10000
18285       pmax=1
18286
18287       do k=1,3
18288       c(k,i)=0.0D0
18289       c(k,j)=0.0D0
18290       c(k,nres+i)=0.0D0
18291       c(k,nres+j)=0.0D0
18292       enddo
18293
18294       do l=1,lmax
18295
18296 !t        wi=ran_number(0.0D0,pi)
18297 !        wi=ran_number(0.0D0,pi/6.0D0)
18298 !        wi=0.0D0
18299 !t        tj=ran_number(0.0D0,pi)
18300 !t        pj=ran_number(0.0D0,pi)
18301 !        pj=ran_number(0.0D0,pi/6.0D0)
18302 !        pj=0.0D0
18303
18304       do p=1,pmax
18305 !t           rij=ran_number(rmin,rmax)
18306
18307          c(1,j)=d*sin(pj)*cos(tj)
18308          c(2,j)=d*sin(pj)*sin(tj)
18309          c(3,j)=d*cos(pj)
18310
18311          c(3,nres+i)=-rij
18312
18313          c(1,i)=d*sin(wi)
18314          c(3,i)=-rij-d*cos(wi)
18315
18316          do k=1,3
18317             dc(k,nres+i)=c(k,nres+i)-c(k,i)
18318             dc_norm(k,nres+i)=dc(k,nres+i)/d
18319             dc(k,nres+j)=c(k,nres+j)-c(k,j)
18320             dc_norm(k,nres+j)=dc(k,nres+j)/d
18321          enddo
18322
18323          call dyn_ssbond_ene(i,j,eij)
18324       enddo
18325       enddo
18326       call exit(1)
18327       return
18328       end subroutine check_energies
18329 !-----------------------------------------------------------------------------
18330       subroutine dyn_ssbond_ene(resi,resj,eij)
18331 !      implicit none
18332 !      Includes
18333       use calc_data
18334       use comm_sschecks
18335 !      include 'DIMENSIONS'
18336 !      include 'COMMON.SBRIDGE'
18337 !      include 'COMMON.CHAIN'
18338 !      include 'COMMON.DERIV'
18339 !      include 'COMMON.LOCAL'
18340 !      include 'COMMON.INTERACT'
18341 !      include 'COMMON.VAR'
18342 !      include 'COMMON.IOUNITS'
18343 !      include 'COMMON.CALC'
18344 #ifndef CLUST
18345 #ifndef WHAM
18346        use MD_data
18347 !      include 'COMMON.MD'
18348 !      use MD, only: totT,t_bath
18349 #endif
18350 #endif
18351 !     External functions
18352 !EL      double precision h_base
18353 !EL      external h_base
18354
18355 !     Input arguments
18356       integer :: resi,resj
18357
18358 !     Output arguments
18359       real(kind=8) :: eij
18360
18361 !     Local variables
18362       logical :: havebond
18363       integer itypi,itypj
18364       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
18365       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
18366       real(kind=8),dimension(3) :: dcosom1,dcosom2
18367       real(kind=8) :: ed
18368       real(kind=8) :: pom1,pom2
18369       real(kind=8) :: ljA,ljB,ljXs
18370       real(kind=8),dimension(1:3) :: d_ljB
18371       real(kind=8) :: ssA,ssB,ssC,ssXs
18372       real(kind=8) :: ssxm,ljxm,ssm,ljm
18373       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
18374       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
18375       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
18376 !-------FIRST METHOD
18377       real(kind=8) :: xm
18378       real(kind=8),dimension(1:3) :: d_xm
18379 !-------END FIRST METHOD
18380 !-------SECOND METHOD
18381 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
18382 !-------END SECOND METHOD
18383
18384 !-------TESTING CODE
18385 !el      logical :: checkstop,transgrad
18386 !el      common /sschecks/ checkstop,transgrad
18387
18388       integer :: icheck,nicheck,jcheck,njcheck
18389       real(kind=8),dimension(-1:1) :: echeck
18390       real(kind=8) :: deps,ssx0,ljx0
18391 !-------END TESTING CODE
18392
18393       eij=0.0d0
18394       i=resi
18395       j=resj
18396
18397 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
18398 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
18399
18400       itypi=itype(i,1)
18401       dxi=dc_norm(1,nres+i)
18402       dyi=dc_norm(2,nres+i)
18403       dzi=dc_norm(3,nres+i)
18404       dsci_inv=vbld_inv(i+nres)
18405
18406       itypj=itype(j,1)
18407       xj=c(1,nres+j)-c(1,nres+i)
18408       yj=c(2,nres+j)-c(2,nres+i)
18409       zj=c(3,nres+j)-c(3,nres+i)
18410       dxj=dc_norm(1,nres+j)
18411       dyj=dc_norm(2,nres+j)
18412       dzj=dc_norm(3,nres+j)
18413       dscj_inv=vbld_inv(j+nres)
18414
18415       chi1=chi(itypi,itypj)
18416       chi2=chi(itypj,itypi)
18417       chi12=chi1*chi2
18418       chip1=chip(itypi)
18419       chip2=chip(itypj)
18420       chip12=chip1*chip2
18421       alf1=alp(itypi)
18422       alf2=alp(itypj)
18423       alf12=0.5D0*(alf1+alf2)
18424
18425       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
18426       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18427 !     The following are set in sc_angular
18428 !      erij(1)=xj*rij
18429 !      erij(2)=yj*rij
18430 !      erij(3)=zj*rij
18431 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
18432 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
18433 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
18434       call sc_angular
18435       rij=1.0D0/rij  ! Reset this so it makes sense
18436
18437       sig0ij=sigma(itypi,itypj)
18438       sig=sig0ij*dsqrt(1.0D0/sigsq)
18439
18440       ljXs=sig-sig0ij
18441       ljA=eps1*eps2rt**2*eps3rt**2
18442       ljB=ljA*bb_aq(itypi,itypj)
18443       ljA=ljA*aa_aq(itypi,itypj)
18444       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
18445
18446       ssXs=d0cm
18447       deltat1=1.0d0-om1
18448       deltat2=1.0d0+om2
18449       deltat12=om2-om1+2.0d0
18450       cosphi=om12-om1*om2
18451       ssA=akcm
18452       ssB=akct*deltat12
18453       ssC=ss_depth &
18454          +akth*(deltat1*deltat1+deltat2*deltat2) &
18455          +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
18456       ssxm=ssXs-0.5D0*ssB/ssA
18457
18458 !-------TESTING CODE
18459 !$$$c     Some extra output
18460 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
18461 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
18462 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
18463 !$$$      if (ssx0.gt.0.0d0) then
18464 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
18465 !$$$      else
18466 !$$$        ssx0=ssxm
18467 !$$$      endif
18468 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
18469 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
18470 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
18471 !$$$      return
18472 !-------END TESTING CODE
18473
18474 !-------TESTING CODE
18475 !     Stop and plot energy and derivative as a function of distance
18476       if (checkstop) then
18477       ssm=ssC-0.25D0*ssB*ssB/ssA
18478       ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18479       if (ssm.lt.ljm .and. &
18480            dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
18481         nicheck=1000
18482         njcheck=1
18483         deps=0.5d-7
18484       else
18485         checkstop=.false.
18486       endif
18487       endif
18488       if (.not.checkstop) then
18489       nicheck=0
18490       njcheck=-1
18491       endif
18492
18493       do icheck=0,nicheck
18494       do jcheck=-1,njcheck
18495       if (checkstop) rij=(ssxm-1.0d0)+ &
18496            ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
18497 !-------END TESTING CODE
18498
18499       if (rij.gt.ljxm) then
18500       havebond=.false.
18501       ljd=rij-ljXs
18502       fac=(1.0D0/ljd)**expon
18503       e1=fac*fac*aa_aq(itypi,itypj)
18504       e2=fac*bb_aq(itypi,itypj)
18505       eij=eps1*eps2rt*eps3rt*(e1+e2)
18506       eps2der=eij*eps3rt
18507       eps3der=eij*eps2rt
18508       eij=eij*eps2rt*eps3rt
18509
18510       sigder=-sig/sigsq
18511       e1=e1*eps1*eps2rt**2*eps3rt**2
18512       ed=-expon*(e1+eij)/ljd
18513       sigder=ed*sigder
18514       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
18515       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
18516       eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
18517            -2.0D0*alf12*eps3der+sigder*sigsq_om12
18518       else if (rij.lt.ssxm) then
18519       havebond=.true.
18520       ssd=rij-ssXs
18521       eij=ssA*ssd*ssd+ssB*ssd+ssC
18522
18523       ed=2*akcm*ssd+akct*deltat12
18524       pom1=akct*ssd
18525       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
18526       eom1=-2*akth*deltat1-pom1-om2*pom2
18527       eom2= 2*akth*deltat2+pom1-om1*pom2
18528       eom12=pom2
18529       else
18530       omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
18531
18532       d_ssxm(1)=0.5D0*akct/ssA
18533       d_ssxm(2)=-d_ssxm(1)
18534       d_ssxm(3)=0.0D0
18535
18536       d_ljxm(1)=sig0ij/sqrt(sigsq**3)
18537       d_ljxm(2)=d_ljxm(1)*sigsq_om2
18538       d_ljxm(3)=d_ljxm(1)*sigsq_om12
18539       d_ljxm(1)=d_ljxm(1)*sigsq_om1
18540
18541 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18542       xm=0.5d0*(ssxm+ljxm)
18543       do k=1,3
18544         d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
18545       enddo
18546       if (rij.lt.xm) then
18547         havebond=.true.
18548         ssm=ssC-0.25D0*ssB*ssB/ssA
18549         d_ssm(1)=0.5D0*akct*ssB/ssA
18550         d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18551         d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18552         d_ssm(3)=omega
18553         f1=(rij-xm)/(ssxm-xm)
18554         f2=(rij-ssxm)/(xm-ssxm)
18555         h1=h_base(f1,hd1)
18556         h2=h_base(f2,hd2)
18557         eij=ssm*h1+Ht*h2
18558         delta_inv=1.0d0/(xm-ssxm)
18559         deltasq_inv=delta_inv*delta_inv
18560         fac=ssm*hd1-Ht*hd2
18561         fac1=deltasq_inv*fac*(xm-rij)
18562         fac2=deltasq_inv*fac*(rij-ssxm)
18563         ed=delta_inv*(Ht*hd2-ssm*hd1)
18564         eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
18565         eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
18566         eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
18567       else
18568         havebond=.false.
18569         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18570         d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
18571         d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
18572         d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
18573              alf12/eps3rt)
18574         d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
18575         f1=(rij-ljxm)/(xm-ljxm)
18576         f2=(rij-xm)/(ljxm-xm)
18577         h1=h_base(f1,hd1)
18578         h2=h_base(f2,hd2)
18579         eij=Ht*h1+ljm*h2
18580         delta_inv=1.0d0/(ljxm-xm)
18581         deltasq_inv=delta_inv*delta_inv
18582         fac=Ht*hd1-ljm*hd2
18583         fac1=deltasq_inv*fac*(ljxm-rij)
18584         fac2=deltasq_inv*fac*(rij-xm)
18585         ed=delta_inv*(ljm*hd2-Ht*hd1)
18586         eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
18587         eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
18588         eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
18589       endif
18590 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18591
18592 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18593 !$$$        ssd=rij-ssXs
18594 !$$$        ljd=rij-ljXs
18595 !$$$        fac1=rij-ljxm
18596 !$$$        fac2=rij-ssxm
18597 !$$$
18598 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
18599 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
18600 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
18601 !$$$
18602 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
18603 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
18604 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18605 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18606 !$$$        d_ssm(3)=omega
18607 !$$$
18608 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
18609 !$$$        do k=1,3
18610 !$$$          d_ljm(k)=ljm*d_ljB(k)
18611 !$$$        enddo
18612 !$$$        ljm=ljm*ljB
18613 !$$$
18614 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
18615 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
18616 !$$$        d_ss(2)=akct*ssd
18617 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
18618 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
18619 !$$$        d_ss(3)=omega
18620 !$$$
18621 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
18622 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
18623 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
18624 !$$$        do k=1,3
18625 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
18626 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
18627 !$$$        enddo
18628 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
18629 !$$$
18630 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
18631 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
18632 !$$$        h1=h_base(f1,hd1)
18633 !$$$        h2=h_base(f2,hd2)
18634 !$$$        eij=ss*h1+ljf*h2
18635 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
18636 !$$$        deltasq_inv=delta_inv*delta_inv
18637 !$$$        fac=ljf*hd2-ss*hd1
18638 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
18639 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
18640 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
18641 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
18642 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
18643 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
18644 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
18645 !$$$
18646 !$$$        havebond=.false.
18647 !$$$        if (ed.gt.0.0d0) havebond=.true.
18648 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18649
18650       endif
18651
18652       if (havebond) then
18653 !#ifndef CLUST
18654 !#ifndef WHAM
18655 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
18656 !          write(iout,'(a15,f12.2,f8.1,2i5)')
18657 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
18658 !        endif
18659 !#endif
18660 !#endif
18661       dyn_ssbond_ij(i,j)=eij
18662       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
18663       dyn_ssbond_ij(i,j)=1.0d300
18664 !#ifndef CLUST
18665 !#ifndef WHAM
18666 !        write(iout,'(a15,f12.2,f8.1,2i5)')
18667 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
18668 !#endif
18669 !#endif
18670       endif
18671
18672 !-------TESTING CODE
18673 !el      if (checkstop) then
18674       if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
18675            "CHECKSTOP",rij,eij,ed
18676       echeck(jcheck)=eij
18677 !el      endif
18678       enddo
18679       if (checkstop) then
18680       write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
18681       endif
18682       enddo
18683       if (checkstop) then
18684       transgrad=.true.
18685       checkstop=.false.
18686       endif
18687 !-------END TESTING CODE
18688
18689       do k=1,3
18690       dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
18691       dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
18692       enddo
18693       do k=1,3
18694       gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
18695       enddo
18696       do k=1,3
18697       gvdwx(k,i)=gvdwx(k,i)-gg(k) &
18698            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
18699            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
18700       gvdwx(k,j)=gvdwx(k,j)+gg(k) &
18701            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
18702            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
18703       enddo
18704 !grad      do k=i,j-1
18705 !grad        do l=1,3
18706 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
18707 !grad        enddo
18708 !grad      enddo
18709
18710       do l=1,3
18711       gvdwc(l,i)=gvdwc(l,i)-gg(l)
18712       gvdwc(l,j)=gvdwc(l,j)+gg(l)
18713       enddo
18714
18715       return
18716       end subroutine dyn_ssbond_ene
18717 !--------------------------------------------------------------------------
18718        subroutine triple_ssbond_ene(resi,resj,resk,eij)
18719 !      implicit none
18720 !      Includes
18721       use calc_data
18722       use comm_sschecks
18723 !      include 'DIMENSIONS'
18724 !      include 'COMMON.SBRIDGE'
18725 !      include 'COMMON.CHAIN'
18726 !      include 'COMMON.DERIV'
18727 !      include 'COMMON.LOCAL'
18728 !      include 'COMMON.INTERACT'
18729 !      include 'COMMON.VAR'
18730 !      include 'COMMON.IOUNITS'
18731 !      include 'COMMON.CALC'
18732 #ifndef CLUST
18733 #ifndef WHAM
18734        use MD_data
18735 !      include 'COMMON.MD'
18736 !      use MD, only: totT,t_bath
18737 #endif
18738 #endif
18739       double precision h_base
18740       external h_base
18741
18742 !c     Input arguments
18743       integer resi,resj,resk,m,itypi,itypj,itypk
18744
18745 !c     Output arguments
18746       double precision eij,eij1,eij2,eij3
18747
18748 !c     Local variables
18749       logical havebond
18750 !c      integer itypi,itypj,k,l
18751       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
18752       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
18753       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
18754       double precision sig0ij,ljd,sig,fac,e1,e2
18755       double precision dcosom1(3),dcosom2(3),ed
18756       double precision pom1,pom2
18757       double precision ljA,ljB,ljXs
18758       double precision d_ljB(1:3)
18759       double precision ssA,ssB,ssC,ssXs
18760       double precision ssxm,ljxm,ssm,ljm
18761       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
18762       eij=0.0
18763       if (dtriss.eq.0) return
18764       i=resi
18765       j=resj
18766       k=resk
18767 !C      write(iout,*) resi,resj,resk
18768       itypi=itype(i,1)
18769       dxi=dc_norm(1,nres+i)
18770       dyi=dc_norm(2,nres+i)
18771       dzi=dc_norm(3,nres+i)
18772       dsci_inv=vbld_inv(i+nres)
18773       xi=c(1,nres+i)
18774       yi=c(2,nres+i)
18775       zi=c(3,nres+i)
18776       call to_box(xi,yi,zi)
18777       itypj=itype(j,1)
18778       xj=c(1,nres+j)
18779       yj=c(2,nres+j)
18780       zj=c(3,nres+j)
18781       call to_box(xj,yj,zj)
18782       dxj=dc_norm(1,nres+j)
18783       dyj=dc_norm(2,nres+j)
18784       dzj=dc_norm(3,nres+j)
18785       dscj_inv=vbld_inv(j+nres)
18786       itypk=itype(k,1)
18787       xk=c(1,nres+k)
18788       yk=c(2,nres+k)
18789       zk=c(3,nres+k)
18790        call to_box(xk,yk,zk)
18791       dxk=dc_norm(1,nres+k)
18792       dyk=dc_norm(2,nres+k)
18793       dzk=dc_norm(3,nres+k)
18794       dscj_inv=vbld_inv(k+nres)
18795       xij=xj-xi
18796       xik=xk-xi
18797       xjk=xk-xj
18798       yij=yj-yi
18799       yik=yk-yi
18800       yjk=yk-yj
18801       zij=zj-zi
18802       zik=zk-zi
18803       zjk=zk-zj
18804       rrij=(xij*xij+yij*yij+zij*zij)
18805       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18806       rrik=(xik*xik+yik*yik+zik*zik)
18807       rik=dsqrt(rrik)
18808       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
18809       rjk=dsqrt(rrjk)
18810 !C there are three combination of distances for each trisulfide bonds
18811 !C The first case the ith atom is the center
18812 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
18813 !C distance y is second distance the a,b,c,d are parameters derived for
18814 !C this problem d parameter was set as a penalty currenlty set to 1.
18815       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
18816       eij1=0.0d0
18817       else
18818       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
18819       endif
18820 !C second case jth atom is center
18821       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
18822       eij2=0.0d0
18823       else
18824       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
18825       endif
18826 !C the third case kth atom is the center
18827       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
18828       eij3=0.0d0
18829       else
18830       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
18831       endif
18832 !C      eij2=0.0
18833 !C      eij3=0.0
18834 !C      eij1=0.0
18835       eij=eij1+eij2+eij3
18836 !C      write(iout,*)i,j,k,eij
18837 !C The energy penalty calculated now time for the gradient part
18838 !C derivative over rij
18839       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18840       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
18841           gg(1)=xij*fac/rij
18842           gg(2)=yij*fac/rij
18843           gg(3)=zij*fac/rij
18844       do m=1,3
18845       gvdwx(m,i)=gvdwx(m,i)-gg(m)
18846       gvdwx(m,j)=gvdwx(m,j)+gg(m)
18847       enddo
18848
18849       do l=1,3
18850       gvdwc(l,i)=gvdwc(l,i)-gg(l)
18851       gvdwc(l,j)=gvdwc(l,j)+gg(l)
18852       enddo
18853 !C now derivative over rik
18854       fac=-eij1**2/dtriss* &
18855       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18856       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18857           gg(1)=xik*fac/rik
18858           gg(2)=yik*fac/rik
18859           gg(3)=zik*fac/rik
18860       do m=1,3
18861       gvdwx(m,i)=gvdwx(m,i)-gg(m)
18862       gvdwx(m,k)=gvdwx(m,k)+gg(m)
18863       enddo
18864       do l=1,3
18865       gvdwc(l,i)=gvdwc(l,i)-gg(l)
18866       gvdwc(l,k)=gvdwc(l,k)+gg(l)
18867       enddo
18868 !C now derivative over rjk
18869       fac=-eij2**2/dtriss* &
18870       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
18871       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18872           gg(1)=xjk*fac/rjk
18873           gg(2)=yjk*fac/rjk
18874           gg(3)=zjk*fac/rjk
18875       do m=1,3
18876       gvdwx(m,j)=gvdwx(m,j)-gg(m)
18877       gvdwx(m,k)=gvdwx(m,k)+gg(m)
18878       enddo
18879       do l=1,3
18880       gvdwc(l,j)=gvdwc(l,j)-gg(l)
18881       gvdwc(l,k)=gvdwc(l,k)+gg(l)
18882       enddo
18883       return
18884       end subroutine triple_ssbond_ene
18885
18886
18887
18888 !-----------------------------------------------------------------------------
18889       real(kind=8) function h_base(x,deriv)
18890 !     A smooth function going 0->1 in range [0,1]
18891 !     It should NOT be called outside range [0,1], it will not work there.
18892       implicit none
18893
18894 !     Input arguments
18895       real(kind=8) :: x
18896
18897 !     Output arguments
18898       real(kind=8) :: deriv
18899
18900 !     Local variables
18901       real(kind=8) :: xsq
18902
18903
18904 !     Two parabolas put together.  First derivative zero at extrema
18905 !$$$      if (x.lt.0.5D0) then
18906 !$$$        h_base=2.0D0*x*x
18907 !$$$        deriv=4.0D0*x
18908 !$$$      else
18909 !$$$        deriv=1.0D0-x
18910 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
18911 !$$$        deriv=4.0D0*deriv
18912 !$$$      endif
18913
18914 !     Third degree polynomial.  First derivative zero at extrema
18915       h_base=x*x*(3.0d0-2.0d0*x)
18916       deriv=6.0d0*x*(1.0d0-x)
18917
18918 !     Fifth degree polynomial.  First and second derivatives zero at extrema
18919 !$$$      xsq=x*x
18920 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
18921 !$$$      deriv=x-1.0d0
18922 !$$$      deriv=deriv*deriv
18923 !$$$      deriv=30.0d0*xsq*deriv
18924
18925       return
18926       end function h_base
18927 !-----------------------------------------------------------------------------
18928       subroutine dyn_set_nss
18929 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
18930 !      implicit none
18931       use MD_data, only: totT,t_bath
18932 !     Includes
18933 !      include 'DIMENSIONS'
18934 #ifdef MPI
18935       include "mpif.h"
18936 #endif
18937 !      include 'COMMON.SBRIDGE'
18938 !      include 'COMMON.CHAIN'
18939 !      include 'COMMON.IOUNITS'
18940 !      include 'COMMON.SETUP'
18941 !      include 'COMMON.MD'
18942 !     Local variables
18943       real(kind=8) :: emin
18944       integer :: i,j,imin,ierr
18945       integer :: diff,allnss,newnss
18946       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18947             newihpb,newjhpb
18948       logical :: found
18949       integer,dimension(0:nfgtasks) :: i_newnss
18950       integer,dimension(0:nfgtasks) :: displ
18951       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18952       integer :: g_newnss
18953
18954       allnss=0
18955       do i=1,nres-1
18956       do j=i+1,nres
18957         if (dyn_ssbond_ij(i,j).lt.1.0d300) then
18958           allnss=allnss+1
18959           allflag(allnss)=0
18960           allihpb(allnss)=i
18961           alljhpb(allnss)=j
18962         endif
18963       enddo
18964       enddo
18965
18966 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18967
18968  1    emin=1.0d300
18969       do i=1,allnss
18970       if (allflag(i).eq.0 .and. &
18971            dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
18972         emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
18973         imin=i
18974       endif
18975       enddo
18976       if (emin.lt.1.0d300) then
18977       allflag(imin)=1
18978       do i=1,allnss
18979         if (allflag(i).eq.0 .and. &
18980              (allihpb(i).eq.allihpb(imin) .or. &
18981              alljhpb(i).eq.allihpb(imin) .or. &
18982              allihpb(i).eq.alljhpb(imin) .or. &
18983              alljhpb(i).eq.alljhpb(imin))) then
18984           allflag(i)=-1
18985         endif
18986       enddo
18987       goto 1
18988       endif
18989
18990 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18991
18992       newnss=0
18993       do i=1,allnss
18994       if (allflag(i).eq.1) then
18995         newnss=newnss+1
18996         newihpb(newnss)=allihpb(i)
18997         newjhpb(newnss)=alljhpb(i)
18998       endif
18999       enddo
19000
19001 #ifdef MPI
19002       if (nfgtasks.gt.1)then
19003
19004       call MPI_Reduce(newnss,g_newnss,1,&
19005         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
19006       call MPI_Gather(newnss,1,MPI_INTEGER,&
19007                   i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
19008       displ(0)=0
19009       do i=1,nfgtasks-1,1
19010         displ(i)=i_newnss(i-1)+displ(i-1)
19011       enddo
19012       call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
19013                    g_newihpb,i_newnss,displ,MPI_INTEGER,&
19014                    king,FG_COMM,IERR)
19015       call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
19016                    g_newjhpb,i_newnss,displ,MPI_INTEGER,&
19017                    king,FG_COMM,IERR)
19018       if(fg_rank.eq.0) then
19019 !         print *,'g_newnss',g_newnss
19020 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
19021 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
19022        newnss=g_newnss
19023        do i=1,newnss
19024         newihpb(i)=g_newihpb(i)
19025         newjhpb(i)=g_newjhpb(i)
19026        enddo
19027       endif
19028       endif
19029 #endif
19030
19031       diff=newnss-nss
19032
19033 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
19034 !       print *,newnss,nss,maxdim
19035       do i=1,nss
19036       found=.false.
19037 !        print *,newnss
19038       do j=1,newnss
19039 !!          print *,j
19040         if (idssb(i).eq.newihpb(j) .and. &
19041              jdssb(i).eq.newjhpb(j)) found=.true.
19042       enddo
19043 #ifndef CLUST
19044 #ifndef WHAM
19045 !        write(iout,*) "found",found,i,j
19046       if (.not.found.and.fg_rank.eq.0) &
19047           write(iout,'(a15,f12.2,f8.1,2i5)') &
19048            "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
19049 #endif
19050 #endif
19051       enddo
19052
19053       do i=1,newnss
19054       found=.false.
19055       do j=1,nss
19056 !          print *,i,j
19057         if (newihpb(i).eq.idssb(j) .and. &
19058              newjhpb(i).eq.jdssb(j)) found=.true.
19059       enddo
19060 #ifndef CLUST
19061 #ifndef WHAM
19062 !        write(iout,*) "found",found,i,j
19063       if (.not.found.and.fg_rank.eq.0) &
19064           write(iout,'(a15,f12.2,f8.1,2i5)') &
19065            "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
19066 #endif
19067 #endif
19068       enddo
19069
19070       nss=newnss
19071       do i=1,nss
19072       idssb(i)=newihpb(i)
19073       jdssb(i)=newjhpb(i)
19074       enddo
19075
19076       return
19077       end subroutine dyn_set_nss
19078 ! Lipid transfer energy function
19079       subroutine Eliptransfer(eliptran)
19080 !C this is done by Adasko
19081 !C      print *,"wchodze"
19082 !C structure of box:
19083 !C      water
19084 !C--bordliptop-- buffore starts
19085 !C--bufliptop--- here true lipid starts
19086 !C      lipid
19087 !C--buflipbot--- lipid ends buffore starts
19088 !C--bordlipbot--buffore ends
19089       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
19090       integer :: i
19091       eliptran=0.0
19092 !      print *, "I am in eliptran"
19093       do i=ilip_start,ilip_end
19094 !C       do i=1,1
19095       if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
19096        cycle
19097
19098       positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
19099       if (positi.le.0.0) positi=positi+boxzsize
19100 !C        print *,i
19101 !C first for peptide groups
19102 !c for each residue check if it is in lipid or lipid water border area
19103        if ((positi.gt.bordlipbot)  &
19104       .and.(positi.lt.bordliptop)) then
19105 !C the energy transfer exist
19106       if (positi.lt.buflipbot) then
19107 !C what fraction I am in
19108        fracinbuf=1.0d0-      &
19109            ((positi-bordlipbot)/lipbufthick)
19110 !C lipbufthick is thickenes of lipid buffore
19111        sslip=sscalelip(fracinbuf)
19112        ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19113        eliptran=eliptran+sslip*pepliptran
19114        gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19115        gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19116 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19117
19118 !C        print *,"doing sccale for lower part"
19119 !C         print *,i,sslip,fracinbuf,ssgradlip
19120       elseif (positi.gt.bufliptop) then
19121        fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
19122        sslip=sscalelip(fracinbuf)
19123        ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19124        eliptran=eliptran+sslip*pepliptran
19125        gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19126        gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19127 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19128 !C          print *, "doing sscalefor top part"
19129 !C         print *,i,sslip,fracinbuf,ssgradlip
19130       else
19131        eliptran=eliptran+pepliptran
19132 !C         print *,"I am in true lipid"
19133       endif
19134 !C       else
19135 !C       eliptran=elpitran+0.0 ! I am in water
19136        endif
19137        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
19138        enddo
19139 ! here starts the side chain transfer
19140        do i=ilip_start,ilip_end
19141       if (itype(i,1).eq.ntyp1) cycle
19142       positi=(mod(c(3,i+nres),boxzsize))
19143       if (positi.le.0) positi=positi+boxzsize
19144 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19145 !c for each residue check if it is in lipid or lipid water border area
19146 !C       respos=mod(c(3,i+nres),boxzsize)
19147 !C       print *,positi,bordlipbot,buflipbot
19148        if ((positi.gt.bordlipbot) &
19149        .and.(positi.lt.bordliptop)) then
19150 !C the energy transfer exist
19151       if (positi.lt.buflipbot) then
19152        fracinbuf=1.0d0-   &
19153          ((positi-bordlipbot)/lipbufthick)
19154 !C lipbufthick is thickenes of lipid buffore
19155        sslip=sscalelip(fracinbuf)
19156        ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19157        eliptran=eliptran+sslip*liptranene(itype(i,1))
19158        gliptranx(3,i)=gliptranx(3,i) &
19159       +ssgradlip*liptranene(itype(i,1))
19160        gliptranc(3,i-1)= gliptranc(3,i-1) &
19161       +ssgradlip*liptranene(itype(i,1))
19162 !C         print *,"doing sccale for lower part"
19163       elseif (positi.gt.bufliptop) then
19164        fracinbuf=1.0d0-  &
19165       ((bordliptop-positi)/lipbufthick)
19166        sslip=sscalelip(fracinbuf)
19167        ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19168        eliptran=eliptran+sslip*liptranene(itype(i,1))
19169        gliptranx(3,i)=gliptranx(3,i)  &
19170        +ssgradlip*liptranene(itype(i,1))
19171        gliptranc(3,i-1)= gliptranc(3,i-1) &
19172       +ssgradlip*liptranene(itype(i,1))
19173 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19174       else
19175        eliptran=eliptran+liptranene(itype(i,1))
19176 !C         print *,"I am in true lipid"
19177       endif
19178       endif ! if in lipid or buffor
19179 !C       else
19180 !C       eliptran=elpitran+0.0 ! I am in water
19181       if (energy_dec) write(iout,*) i,"eliptran=",eliptran
19182        enddo
19183        return
19184        end  subroutine Eliptransfer
19185 !----------------------------------NANO FUNCTIONS
19186 !C-----------------------------------------------------------------------
19187 !C-----------------------------------------------------------
19188 !C This subroutine is to mimic the histone like structure but as well can be
19189 !C utilizet to nanostructures (infinit) small modification has to be used to
19190 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19191 !C gradient has to be modified at the ends
19192 !C The energy function is Kihara potential
19193 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19194 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19195 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19196 !C simple Kihara potential
19197       subroutine calctube(Etube)
19198       real(kind=8),dimension(3) :: vectube
19199       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19200        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
19201        sc_aa_tube,sc_bb_tube
19202       integer :: i,j,iti
19203       Etube=0.0d0
19204       do i=itube_start,itube_end
19205       enetube(i)=0.0d0
19206       enetube(i+nres)=0.0d0
19207       enddo
19208 !C first we calculate the distance from tube center
19209 !C for UNRES
19210        do i=itube_start,itube_end
19211 !C lets ommit dummy atoms for now
19212        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19213 !C now calculate distance from center of tube and direction vectors
19214       xmin=boxxsize
19215       ymin=boxysize
19216 ! Find minimum distance in periodic box
19217       do j=-1,1
19218        vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19219        vectube(1)=vectube(1)+boxxsize*j
19220        vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19221        vectube(2)=vectube(2)+boxysize*j
19222        xminact=abs(vectube(1)-tubecenter(1))
19223        yminact=abs(vectube(2)-tubecenter(2))
19224          if (xmin.gt.xminact) then
19225           xmin=xminact
19226           xtemp=vectube(1)
19227          endif
19228          if (ymin.gt.yminact) then
19229            ymin=yminact
19230            ytemp=vectube(2)
19231           endif
19232        enddo
19233       vectube(1)=xtemp
19234       vectube(2)=ytemp
19235       vectube(1)=vectube(1)-tubecenter(1)
19236       vectube(2)=vectube(2)-tubecenter(2)
19237
19238 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19239 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19240
19241 !C as the tube is infinity we do not calculate the Z-vector use of Z
19242 !C as chosen axis
19243       vectube(3)=0.0d0
19244 !C now calculte the distance
19245        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19246 !C now normalize vector
19247       vectube(1)=vectube(1)/tub_r
19248       vectube(2)=vectube(2)/tub_r
19249 !C calculte rdiffrence between r and r0
19250       rdiff=tub_r-tubeR0
19251 !C and its 6 power
19252       rdiff6=rdiff**6.0d0
19253 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19254        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19255 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19256 !C       print *,rdiff,rdiff6,pep_aa_tube
19257 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19258 !C now we calculate gradient
19259        fac=(-12.0d0*pep_aa_tube/rdiff6- &
19260           6.0d0*pep_bb_tube)/rdiff6/rdiff
19261 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19262 !C     &rdiff,fac
19263 !C now direction of gg_tube vector
19264       do j=1,3
19265       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19266       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19267       enddo
19268       enddo
19269 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19270 !C        print *,gg_tube(1,0),"TU"
19271
19272
19273        do i=itube_start,itube_end
19274 !C Lets not jump over memory as we use many times iti
19275        iti=itype(i,1)
19276 !C lets ommit dummy atoms for now
19277        if ((iti.eq.ntyp1)  &
19278 !C in UNRES uncomment the line below as GLY has no side-chain...
19279 !C      .or.(iti.eq.10)
19280       ) cycle
19281       xmin=boxxsize
19282       ymin=boxysize
19283       do j=-1,1
19284        vectube(1)=mod((c(1,i+nres)),boxxsize)
19285        vectube(1)=vectube(1)+boxxsize*j
19286        vectube(2)=mod((c(2,i+nres)),boxysize)
19287        vectube(2)=vectube(2)+boxysize*j
19288
19289        xminact=abs(vectube(1)-tubecenter(1))
19290        yminact=abs(vectube(2)-tubecenter(2))
19291          if (xmin.gt.xminact) then
19292           xmin=xminact
19293           xtemp=vectube(1)
19294          endif
19295          if (ymin.gt.yminact) then
19296            ymin=yminact
19297            ytemp=vectube(2)
19298           endif
19299        enddo
19300       vectube(1)=xtemp
19301       vectube(2)=ytemp
19302 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19303 !C     &     tubecenter(2)
19304       vectube(1)=vectube(1)-tubecenter(1)
19305       vectube(2)=vectube(2)-tubecenter(2)
19306
19307 !C as the tube is infinity we do not calculate the Z-vector use of Z
19308 !C as chosen axis
19309       vectube(3)=0.0d0
19310 !C now calculte the distance
19311        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19312 !C now normalize vector
19313       vectube(1)=vectube(1)/tub_r
19314       vectube(2)=vectube(2)/tub_r
19315
19316 !C calculte rdiffrence between r and r0
19317       rdiff=tub_r-tubeR0
19318 !C and its 6 power
19319       rdiff6=rdiff**6.0d0
19320 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19321        sc_aa_tube=sc_aa_tube_par(iti)
19322        sc_bb_tube=sc_bb_tube_par(iti)
19323        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19324        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
19325            6.0d0*sc_bb_tube/rdiff6/rdiff
19326 !C now direction of gg_tube vector
19327        do j=1,3
19328         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19329         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19330        enddo
19331       enddo
19332       do i=itube_start,itube_end
19333         Etube=Etube+enetube(i)+enetube(i+nres)
19334       enddo
19335 !C        print *,"ETUBE", etube
19336       return
19337       end subroutine calctube
19338 !C TO DO 1) add to total energy
19339 !C       2) add to gradient summation
19340 !C       3) add reading parameters (AND of course oppening of PARAM file)
19341 !C       4) add reading the center of tube
19342 !C       5) add COMMONs
19343 !C       6) add to zerograd
19344 !C       7) allocate matrices
19345
19346
19347 !C-----------------------------------------------------------------------
19348 !C-----------------------------------------------------------
19349 !C This subroutine is to mimic the histone like structure but as well can be
19350 !C utilizet to nanostructures (infinit) small modification has to be used to
19351 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19352 !C gradient has to be modified at the ends
19353 !C The energy function is Kihara potential
19354 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19355 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19356 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19357 !C simple Kihara potential
19358       subroutine calctube2(Etube)
19359           real(kind=8),dimension(3) :: vectube
19360       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19361        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
19362        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
19363       integer:: i,j,iti
19364       Etube=0.0d0
19365       do i=itube_start,itube_end
19366       enetube(i)=0.0d0
19367       enetube(i+nres)=0.0d0
19368       enddo
19369 !C first we calculate the distance from tube center
19370 !C first sugare-phosphate group for NARES this would be peptide group
19371 !C for UNRES
19372        do i=itube_start,itube_end
19373 !C lets ommit dummy atoms for now
19374
19375        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19376 !C now calculate distance from center of tube and direction vectors
19377 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19378 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19379 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19380 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19381       xmin=boxxsize
19382       ymin=boxysize
19383       do j=-1,1
19384        vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19385        vectube(1)=vectube(1)+boxxsize*j
19386        vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19387        vectube(2)=vectube(2)+boxysize*j
19388
19389        xminact=abs(vectube(1)-tubecenter(1))
19390        yminact=abs(vectube(2)-tubecenter(2))
19391          if (xmin.gt.xminact) then
19392           xmin=xminact
19393           xtemp=vectube(1)
19394          endif
19395          if (ymin.gt.yminact) then
19396            ymin=yminact
19397            ytemp=vectube(2)
19398           endif
19399        enddo
19400       vectube(1)=xtemp
19401       vectube(2)=ytemp
19402       vectube(1)=vectube(1)-tubecenter(1)
19403       vectube(2)=vectube(2)-tubecenter(2)
19404
19405 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19406 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19407
19408 !C as the tube is infinity we do not calculate the Z-vector use of Z
19409 !C as chosen axis
19410       vectube(3)=0.0d0
19411 !C now calculte the distance
19412        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19413 !C now normalize vector
19414       vectube(1)=vectube(1)/tub_r
19415       vectube(2)=vectube(2)/tub_r
19416 !C calculte rdiffrence between r and r0
19417       rdiff=tub_r-tubeR0
19418 !C and its 6 power
19419       rdiff6=rdiff**6.0d0
19420 !C THIS FRAGMENT MAKES TUBE FINITE
19421       positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19422       if (positi.le.0) positi=positi+boxzsize
19423 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19424 !c for each residue check if it is in lipid or lipid water border area
19425 !C       respos=mod(c(3,i+nres),boxzsize)
19426 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19427        if ((positi.gt.bordtubebot)  &
19428       .and.(positi.lt.bordtubetop)) then
19429 !C the energy transfer exist
19430       if (positi.lt.buftubebot) then
19431        fracinbuf=1.0d0-  &
19432          ((positi-bordtubebot)/tubebufthick)
19433 !C lipbufthick is thickenes of lipid buffore
19434        sstube=sscalelip(fracinbuf)
19435        ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19436 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19437        enetube(i)=enetube(i)+sstube*tubetranenepep
19438 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19439 !C     &+ssgradtube*tubetranene(itype(i,1))
19440 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19441 !C     &+ssgradtube*tubetranene(itype(i,1))
19442 !C         print *,"doing sccale for lower part"
19443       elseif (positi.gt.buftubetop) then
19444        fracinbuf=1.0d0-  &
19445       ((bordtubetop-positi)/tubebufthick)
19446        sstube=sscalelip(fracinbuf)
19447        ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19448        enetube(i)=enetube(i)+sstube*tubetranenepep
19449 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19450 !C     &+ssgradtube*tubetranene(itype(i,1))
19451 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19452 !C     &+ssgradtube*tubetranene(itype(i,1))
19453 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19454       else
19455        sstube=1.0d0
19456        ssgradtube=0.0d0
19457        enetube(i)=enetube(i)+sstube*tubetranenepep
19458 !C         print *,"I am in true lipid"
19459       endif
19460       else
19461 !C          sstube=0.0d0
19462 !C          ssgradtube=0.0d0
19463       cycle
19464       endif ! if in lipid or buffor
19465
19466 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19467        enetube(i)=enetube(i)+sstube* &
19468       (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
19469 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19470 !C       print *,rdiff,rdiff6,pep_aa_tube
19471 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19472 !C now we calculate gradient
19473        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
19474            6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
19475 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19476 !C     &rdiff,fac
19477
19478 !C now direction of gg_tube vector
19479        do j=1,3
19480       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19481       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19482       enddo
19483        gg_tube(3,i)=gg_tube(3,i)  &
19484        +ssgradtube*enetube(i)/sstube/2.0d0
19485        gg_tube(3,i-1)= gg_tube(3,i-1)  &
19486        +ssgradtube*enetube(i)/sstube/2.0d0
19487
19488       enddo
19489 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19490 !C        print *,gg_tube(1,0),"TU"
19491       do i=itube_start,itube_end
19492 !C Lets not jump over memory as we use many times iti
19493        iti=itype(i,1)
19494 !C lets ommit dummy atoms for now
19495        if ((iti.eq.ntyp1) &
19496 !!C in UNRES uncomment the line below as GLY has no side-chain...
19497          .or.(iti.eq.10) &
19498         ) cycle
19499         vectube(1)=c(1,i+nres)
19500         vectube(1)=mod(vectube(1),boxxsize)
19501         if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19502         vectube(2)=c(2,i+nres)
19503         vectube(2)=mod(vectube(2),boxysize)
19504         if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19505
19506       vectube(1)=vectube(1)-tubecenter(1)
19507       vectube(2)=vectube(2)-tubecenter(2)
19508 !C THIS FRAGMENT MAKES TUBE FINITE
19509       positi=(mod(c(3,i+nres),boxzsize))
19510       if (positi.le.0) positi=positi+boxzsize
19511 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19512 !c for each residue check if it is in lipid or lipid water border area
19513 !C       respos=mod(c(3,i+nres),boxzsize)
19514 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19515
19516        if ((positi.gt.bordtubebot)  &
19517       .and.(positi.lt.bordtubetop)) then
19518 !C the energy transfer exist
19519       if (positi.lt.buftubebot) then
19520        fracinbuf=1.0d0- &
19521           ((positi-bordtubebot)/tubebufthick)
19522 !C lipbufthick is thickenes of lipid buffore
19523        sstube=sscalelip(fracinbuf)
19524        ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19525 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19526        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19527 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19528 !C     &+ssgradtube*tubetranene(itype(i,1))
19529 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19530 !C     &+ssgradtube*tubetranene(itype(i,1))
19531 !C         print *,"doing sccale for lower part"
19532       elseif (positi.gt.buftubetop) then
19533        fracinbuf=1.0d0- &
19534       ((bordtubetop-positi)/tubebufthick)
19535
19536        sstube=sscalelip(fracinbuf)
19537        ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19538        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19539 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19540 !C     &+ssgradtube*tubetranene(itype(i,1))
19541 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19542 !C     &+ssgradtube*tubetranene(itype(i,1))
19543 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19544       else
19545        sstube=1.0d0
19546        ssgradtube=0.0d0
19547        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19548 !C         print *,"I am in true lipid"
19549       endif
19550       else
19551 !C          sstube=0.0d0
19552 !C          ssgradtube=0.0d0
19553       cycle
19554       endif ! if in lipid or buffor
19555 !CEND OF FINITE FRAGMENT
19556 !C as the tube is infinity we do not calculate the Z-vector use of Z
19557 !C as chosen axis
19558       vectube(3)=0.0d0
19559 !C now calculte the distance
19560        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19561 !C now normalize vector
19562       vectube(1)=vectube(1)/tub_r
19563       vectube(2)=vectube(2)/tub_r
19564 !C calculte rdiffrence between r and r0
19565       rdiff=tub_r-tubeR0
19566 !C and its 6 power
19567       rdiff6=rdiff**6.0d0
19568 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19569        sc_aa_tube=sc_aa_tube_par(iti)
19570        sc_bb_tube=sc_bb_tube_par(iti)
19571        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
19572                    *sstube+enetube(i+nres)
19573 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19574 !C now we calculate gradient
19575        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
19576           6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
19577 !C now direction of gg_tube vector
19578        do j=1,3
19579         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19580         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19581        enddo
19582        gg_tube_SC(3,i)=gg_tube_SC(3,i) &
19583        +ssgradtube*enetube(i+nres)/sstube
19584        gg_tube(3,i-1)= gg_tube(3,i-1) &
19585        +ssgradtube*enetube(i+nres)/sstube
19586
19587       enddo
19588       do i=itube_start,itube_end
19589         Etube=Etube+enetube(i)+enetube(i+nres)
19590       enddo
19591 !C        print *,"ETUBE", etube
19592       return
19593       end subroutine calctube2
19594 !=====================================================================================================================================
19595       subroutine calcnano(Etube)
19596       real(kind=8),dimension(3) :: vectube
19597
19598       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19599        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
19600        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
19601        integer:: i,j,iti,r
19602
19603       Etube=0.0d0
19604 !      print *,itube_start,itube_end,"poczatek"
19605       do i=itube_start,itube_end
19606       enetube(i)=0.0d0
19607       enetube(i+nres)=0.0d0
19608       enddo
19609 !C first we calculate the distance from tube center
19610 !C first sugare-phosphate group for NARES this would be peptide group
19611 !C for UNRES
19612        do i=itube_start,itube_end
19613 !C lets ommit dummy atoms for now
19614        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19615 !C now calculate distance from center of tube and direction vectors
19616       xmin=boxxsize
19617       ymin=boxysize
19618       zmin=boxzsize
19619
19620       do j=-1,1
19621        vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19622        vectube(1)=vectube(1)+boxxsize*j
19623        vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19624        vectube(2)=vectube(2)+boxysize*j
19625        vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19626        vectube(3)=vectube(3)+boxzsize*j
19627
19628
19629        xminact=dabs(vectube(1)-tubecenter(1))
19630        yminact=dabs(vectube(2)-tubecenter(2))
19631        zminact=dabs(vectube(3)-tubecenter(3))
19632
19633          if (xmin.gt.xminact) then
19634           xmin=xminact
19635           xtemp=vectube(1)
19636          endif
19637          if (ymin.gt.yminact) then
19638            ymin=yminact
19639            ytemp=vectube(2)
19640           endif
19641          if (zmin.gt.zminact) then
19642            zmin=zminact
19643            ztemp=vectube(3)
19644           endif
19645        enddo
19646       vectube(1)=xtemp
19647       vectube(2)=ytemp
19648       vectube(3)=ztemp
19649
19650       vectube(1)=vectube(1)-tubecenter(1)
19651       vectube(2)=vectube(2)-tubecenter(2)
19652       vectube(3)=vectube(3)-tubecenter(3)
19653
19654 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19655 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19656 !C as the tube is infinity we do not calculate the Z-vector use of Z
19657 !C as chosen axis
19658 !C      vectube(3)=0.0d0
19659 !C now calculte the distance
19660        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19661 !C now normalize vector
19662       vectube(1)=vectube(1)/tub_r
19663       vectube(2)=vectube(2)/tub_r
19664       vectube(3)=vectube(3)/tub_r
19665 !C calculte rdiffrence between r and r0
19666       rdiff=tub_r-tubeR0
19667 !C and its 6 power
19668       rdiff6=rdiff**6.0d0
19669 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19670        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19671 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19672 !C       print *,rdiff,rdiff6,pep_aa_tube
19673 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19674 !C now we calculate gradient
19675        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
19676           6.0d0*pep_bb_tube)/rdiff6/rdiff
19677 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19678 !C     &rdiff,fac
19679        if (acavtubpep.eq.0.0d0) then
19680 !C go to 667
19681        enecavtube(i)=0.0
19682        faccav=0.0
19683        else
19684        denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
19685        enecavtube(i)=  &
19686       (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
19687       /denominator
19688        enecavtube(i)=0.0
19689        faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
19690       *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
19691       +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
19692       /denominator**2.0d0
19693 !C         faccav=0.0
19694 !C         fac=fac+faccav
19695 !C 667     continue
19696        endif
19697         if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
19698       do j=1,3
19699       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19700       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19701       enddo
19702       enddo
19703
19704        do i=itube_start,itube_end
19705       enecavtube(i)=0.0d0
19706 !C Lets not jump over memory as we use many times iti
19707        iti=itype(i,1)
19708 !C lets ommit dummy atoms for now
19709        if ((iti.eq.ntyp1) &
19710 !C in UNRES uncomment the line below as GLY has no side-chain...
19711 !C      .or.(iti.eq.10)
19712        ) cycle
19713       xmin=boxxsize
19714       ymin=boxysize
19715       zmin=boxzsize
19716       do j=-1,1
19717        vectube(1)=dmod((c(1,i+nres)),boxxsize)
19718        vectube(1)=vectube(1)+boxxsize*j
19719        vectube(2)=dmod((c(2,i+nres)),boxysize)
19720        vectube(2)=vectube(2)+boxysize*j
19721        vectube(3)=dmod((c(3,i+nres)),boxzsize)
19722        vectube(3)=vectube(3)+boxzsize*j
19723
19724
19725        xminact=dabs(vectube(1)-tubecenter(1))
19726        yminact=dabs(vectube(2)-tubecenter(2))
19727        zminact=dabs(vectube(3)-tubecenter(3))
19728
19729          if (xmin.gt.xminact) then
19730           xmin=xminact
19731           xtemp=vectube(1)
19732          endif
19733          if (ymin.gt.yminact) then
19734            ymin=yminact
19735            ytemp=vectube(2)
19736           endif
19737          if (zmin.gt.zminact) then
19738            zmin=zminact
19739            ztemp=vectube(3)
19740           endif
19741        enddo
19742       vectube(1)=xtemp
19743       vectube(2)=ytemp
19744       vectube(3)=ztemp
19745
19746 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19747 !C     &     tubecenter(2)
19748       vectube(1)=vectube(1)-tubecenter(1)
19749       vectube(2)=vectube(2)-tubecenter(2)
19750       vectube(3)=vectube(3)-tubecenter(3)
19751 !C now calculte the distance
19752        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19753 !C now normalize vector
19754       vectube(1)=vectube(1)/tub_r
19755       vectube(2)=vectube(2)/tub_r
19756       vectube(3)=vectube(3)/tub_r
19757
19758 !C calculte rdiffrence between r and r0
19759       rdiff=tub_r-tubeR0
19760 !C and its 6 power
19761       rdiff6=rdiff**6.0d0
19762        sc_aa_tube=sc_aa_tube_par(iti)
19763        sc_bb_tube=sc_bb_tube_par(iti)
19764        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19765 !C       enetube(i+nres)=0.0d0
19766 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19767 !C now we calculate gradient
19768        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
19769           6.0d0*sc_bb_tube/rdiff6/rdiff
19770 !C       fac=0.0
19771 !C now direction of gg_tube vector
19772 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
19773        if (acavtub(iti).eq.0.0d0) then
19774 !C go to 667
19775        enecavtube(i+nres)=0.0d0
19776        faccav=0.0d0
19777        else
19778        denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
19779        enecavtube(i+nres)=   &
19780       (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
19781       /denominator
19782 !C         enecavtube(i)=0.0
19783        faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
19784       *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
19785       +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
19786       /denominator**2.0d0
19787 !C         faccav=0.0
19788        fac=fac+faccav
19789 !C 667     continue
19790        endif
19791 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
19792 !C     &   enecavtube(i),faccav
19793 !C         print *,"licz=",
19794 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
19795 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
19796        do j=1,3
19797         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19798         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19799        enddo
19800         if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
19801       enddo
19802
19803
19804
19805       do i=itube_start,itube_end
19806         Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
19807        +enecavtube(i+nres)
19808       enddo
19809 !        do i=1,20
19810 !         print *,"begin", i,"a"
19811 !         do r=1,10000
19812 !          rdiff=r/100.0d0
19813 !          rdiff6=rdiff**6.0d0
19814 !          sc_aa_tube=sc_aa_tube_par(i)
19815 !          sc_bb_tube=sc_bb_tube_par(i)
19816 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19817 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
19818 !          enecavtube(i)=   &
19819 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
19820 !         /denominator
19821
19822 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
19823 !         enddo
19824 !         print *,"end",i,"a"
19825 !        enddo
19826 !C        print *,"ETUBE", etube
19827       return
19828       end subroutine calcnano
19829
19830 !===============================================
19831 !--------------------------------------------------------------------------------
19832 !C first for shielding is setting of function of side-chains
19833
19834        subroutine set_shield_fac2
19835        real(kind=8) :: div77_81=0.974996043d0, &
19836       div4_81=0.2222222222d0
19837        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
19838        scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
19839        short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
19840        sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
19841 !C the vector between center of side_chain and peptide group
19842        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
19843        pept_group,costhet_grad,cosphi_grad_long, &
19844        cosphi_grad_loc,pep_side_norm,side_calf_norm, &
19845        sh_frac_dist_grad,pep_side
19846       integer i,j,k
19847 !C      write(2,*) "ivec",ivec_start,ivec_end
19848       do i=1,nres
19849       fac_shield(i)=0.0d0
19850       ishield_list(i)=0
19851       do j=1,3
19852       grad_shield(j,i)=0.0d0
19853       enddo
19854       enddo
19855       do i=ivec_start,ivec_end
19856 !C      do i=1,nres-1
19857 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19858 !      ishield_list(i)=0
19859       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19860 !Cif there two consequtive dummy atoms there is no peptide group between them
19861 !C the line below has to be changed for FGPROC>1
19862       VolumeTotal=0.0
19863       do k=1,nres
19864        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
19865        dist_pep_side=0.0
19866        dist_side_calf=0.0
19867        do j=1,3
19868 !C first lets set vector conecting the ithe side-chain with kth side-chain
19869       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
19870 !C      pep_side(j)=2.0d0
19871 !C and vector conecting the side-chain with its proper calfa
19872       side_calf(j)=c(j,k+nres)-c(j,k)
19873 !C      side_calf(j)=2.0d0
19874       pept_group(j)=c(j,i)-c(j,i+1)
19875 !C lets have their lenght
19876       dist_pep_side=pep_side(j)**2+dist_pep_side
19877       dist_side_calf=dist_side_calf+side_calf(j)**2
19878       dist_pept_group=dist_pept_group+pept_group(j)**2
19879       enddo
19880        dist_pep_side=sqrt(dist_pep_side)
19881        dist_pept_group=sqrt(dist_pept_group)
19882        dist_side_calf=sqrt(dist_side_calf)
19883       do j=1,3
19884       pep_side_norm(j)=pep_side(j)/dist_pep_side
19885       side_calf_norm(j)=dist_side_calf
19886       enddo
19887 !C now sscale fraction
19888        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
19889 !       print *,buff_shield,"buff",sh_frac_dist
19890 !C now sscale
19891       if (sh_frac_dist.le.0.0) cycle
19892 !C        print *,ishield_list(i),i
19893 !C If we reach here it means that this side chain reaches the shielding sphere
19894 !C Lets add him to the list for gradient
19895       ishield_list(i)=ishield_list(i)+1
19896 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
19897 !C this list is essential otherwise problem would be O3
19898       shield_list(ishield_list(i),i)=k
19899 !C Lets have the sscale value
19900       if (sh_frac_dist.gt.1.0) then
19901        scale_fac_dist=1.0d0
19902        do j=1,3
19903        sh_frac_dist_grad(j)=0.0d0
19904        enddo
19905       else
19906        scale_fac_dist=-sh_frac_dist*sh_frac_dist &
19907                   *(2.0d0*sh_frac_dist-3.0d0)
19908        fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
19909                    /dist_pep_side/buff_shield*0.5d0
19910        do j=1,3
19911        sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
19912 !C         sh_frac_dist_grad(j)=0.0d0
19913 !C         scale_fac_dist=1.0d0
19914 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
19915 !C     &                    sh_frac_dist_grad(j)
19916        enddo
19917       endif
19918 !C this is what is now we have the distance scaling now volume...
19919       short=short_r_sidechain(itype(k,1))
19920       long=long_r_sidechain(itype(k,1))
19921       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
19922       sinthet=short/dist_pep_side*costhet
19923 !      print *,"SORT",short,long,sinthet,costhet
19924 !C now costhet_grad
19925 !C       costhet=0.6d0
19926 !C       sinthet=0.8
19927        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
19928 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
19929 !C     &             -short/dist_pep_side**2/costhet)
19930 !C       costhet_fac=0.0d0
19931        do j=1,3
19932        costhet_grad(j)=costhet_fac*pep_side(j)
19933        enddo
19934 !C remember for the final gradient multiply costhet_grad(j)
19935 !C for side_chain by factor -2 !
19936 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
19937 !C pep_side0pept_group is vector multiplication
19938       pep_side0pept_group=0.0d0
19939       do j=1,3
19940       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
19941       enddo
19942       cosalfa=(pep_side0pept_group/ &
19943       (dist_pep_side*dist_side_calf))
19944       fac_alfa_sin=1.0d0-cosalfa**2
19945       fac_alfa_sin=dsqrt(fac_alfa_sin)
19946       rkprim=fac_alfa_sin*(long-short)+short
19947 !C      rkprim=short
19948
19949 !C now costhet_grad
19950        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
19951 !C       cosphi=0.6
19952        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
19953        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
19954          dist_pep_side**2)
19955 !C       sinphi=0.8
19956        do j=1,3
19957        cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
19958       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19959       *(long-short)/fac_alfa_sin*cosalfa/ &
19960       ((dist_pep_side*dist_side_calf))* &
19961       ((side_calf(j))-cosalfa* &
19962       ((pep_side(j)/dist_pep_side)*dist_side_calf))
19963 !C       cosphi_grad_long(j)=0.0d0
19964       cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19965       *(long-short)/fac_alfa_sin*cosalfa &
19966       /((dist_pep_side*dist_side_calf))* &
19967       (pep_side(j)- &
19968       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
19969 !C       cosphi_grad_loc(j)=0.0d0
19970        enddo
19971 !C      print *,sinphi,sinthet
19972       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
19973                    /VSolvSphere_div
19974 !C     &                    *wshield
19975 !C now the gradient...
19976       do j=1,3
19977       grad_shield(j,i)=grad_shield(j,i) &
19978 !C gradient po skalowaniu
19979                  +(sh_frac_dist_grad(j)*VofOverlap &
19980 !C  gradient po costhet
19981           +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
19982       (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
19983           sinphi/sinthet*costhet*costhet_grad(j) &
19984          +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19985       )*wshield
19986 !C grad_shield_side is Cbeta sidechain gradient
19987       grad_shield_side(j,ishield_list(i),i)=&
19988            (sh_frac_dist_grad(j)*-2.0d0&
19989            *VofOverlap&
19990           -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19991        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
19992           sinphi/sinthet*costhet*costhet_grad(j)&
19993          +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19994           )*wshield
19995 !       print *, 1.0d0/(-dsqrt(1.0d0-sinphi*sinthet)),&
19996 !            sinphi/sinthet,&
19997 !           +sinthet/sinphi,"HERE"
19998        grad_shield_loc(j,ishield_list(i),i)=   &
19999           scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20000       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
20001           sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
20002            ))&
20003            *wshield
20004 !         print *,grad_shield_loc(j,ishield_list(i),i)
20005       enddo
20006       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
20007       enddo
20008       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
20009
20010 !      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
20011       enddo
20012       return
20013       end subroutine set_shield_fac2
20014 !----------------------------------------------------------------------------
20015 ! SOUBROUTINE FOR AFM
20016        subroutine AFMvel(Eafmforce)
20017        use MD_data, only:totTafm
20018       real(kind=8),dimension(3) :: diffafm
20019       real(kind=8) :: afmdist,Eafmforce
20020        integer :: i
20021 !C Only for check grad COMMENT if not used for checkgrad
20022 !C      totT=3.0d0
20023 !C--------------------------------------------------------
20024 !C      print *,"wchodze"
20025       afmdist=0.0d0
20026       Eafmforce=0.0d0
20027       do i=1,3
20028       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20029       afmdist=afmdist+diffafm(i)**2
20030       enddo
20031       afmdist=dsqrt(afmdist)
20032 !      totTafm=3.0
20033       Eafmforce=0.5d0*forceAFMconst &
20034       *(distafminit+totTafm*velAFMconst-afmdist)**2
20035 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
20036       do i=1,3
20037       gradafm(i,afmend-1)=-forceAFMconst* &
20038        (distafminit+totTafm*velAFMconst-afmdist) &
20039        *diffafm(i)/afmdist
20040       gradafm(i,afmbeg-1)=forceAFMconst* &
20041       (distafminit+totTafm*velAFMconst-afmdist) &
20042       *diffafm(i)/afmdist
20043       enddo
20044 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
20045       return
20046       end subroutine AFMvel
20047 !---------------------------------------------------------
20048        subroutine AFMforce(Eafmforce)
20049
20050       real(kind=8),dimension(3) :: diffafm
20051 !      real(kind=8) ::afmdist
20052       real(kind=8) :: afmdist,Eafmforce
20053       integer :: i
20054       afmdist=0.0d0
20055       Eafmforce=0.0d0
20056       do i=1,3
20057       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20058       afmdist=afmdist+diffafm(i)**2
20059       enddo
20060       afmdist=dsqrt(afmdist)
20061 !      print *,afmdist,distafminit
20062       Eafmforce=-forceAFMconst*(afmdist-distafminit)
20063       do i=1,3
20064       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
20065       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
20066       enddo
20067 !C      print *,'AFM',Eafmforce
20068       return
20069       end subroutine AFMforce
20070
20071 !-----------------------------------------------------------------------------
20072 #ifdef WHAM
20073       subroutine read_ssHist
20074 !      implicit none
20075 !      Includes
20076 !      include 'DIMENSIONS'
20077 !      include "DIMENSIONS.FREE"
20078 !      include 'COMMON.FREE'
20079 !     Local variables
20080       integer :: i,j
20081       character(len=80) :: controlcard
20082
20083       do i=1,dyn_nssHist
20084       call card_concat(controlcard,.true.)
20085       read(controlcard,*) &
20086            dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
20087       enddo
20088
20089       return
20090       end subroutine read_ssHist
20091 #endif
20092 !-----------------------------------------------------------------------------
20093       integer function indmat(i,j)
20094 !el
20095 ! get the position of the jth ijth fragment of the chain coordinate system
20096 ! in the fromto array.
20097       integer :: i,j
20098
20099       indmat=((2*(nres-2)-i)*(i-1))/2+j-1
20100       return
20101       end function indmat
20102 !-----------------------------------------------------------------------------
20103       real(kind=8) function sigm(x)
20104 !el
20105        real(kind=8) :: x
20106       sigm=0.25d0*x
20107       return
20108       end function sigm
20109 !-----------------------------------------------------------------------------
20110 !-----------------------------------------------------------------------------
20111       subroutine alloc_ener_arrays
20112 !EL Allocation of arrays used by module energy
20113       use MD_data, only: mset
20114 !el local variables
20115       integer :: i,j
20116
20117       if(nres.lt.100) then
20118       maxconts=10*nres
20119       elseif(nres.lt.200) then
20120       maxconts=10*nres      ! Max. number of contacts per residue
20121       else
20122       maxconts=10*nres ! (maxconts=maxres/4)
20123       endif
20124       maxcont=12*nres      ! Max. number of SC contacts
20125       maxvar=6*nres      ! Max. number of variables
20126 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20127       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20128 !----------------------
20129 ! arrays in subroutine init_int_table
20130 !el#ifdef MPI
20131 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
20132 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
20133 !el#endif
20134       allocate(nint_gr(nres))
20135       allocate(nscp_gr(nres))
20136       allocate(ielstart(nres))
20137       allocate(ielend(nres))
20138 !(maxres)
20139       allocate(istart(nres,maxint_gr))
20140       allocate(iend(nres,maxint_gr))
20141 !(maxres,maxint_gr)
20142       allocate(iscpstart(nres,maxint_gr))
20143       allocate(iscpend(nres,maxint_gr))
20144 !(maxres,maxint_gr)
20145       allocate(ielstart_vdw(nres))
20146       allocate(ielend_vdw(nres))
20147 !(maxres)
20148       allocate(nint_gr_nucl(nres))
20149       allocate(nscp_gr_nucl(nres))
20150       allocate(ielstart_nucl(nres))
20151       allocate(ielend_nucl(nres))
20152 !(maxres)
20153       allocate(istart_nucl(nres,maxint_gr))
20154       allocate(iend_nucl(nres,maxint_gr))
20155 !(maxres,maxint_gr)
20156       allocate(iscpstart_nucl(nres,maxint_gr))
20157       allocate(iscpend_nucl(nres,maxint_gr))
20158 !(maxres,maxint_gr)
20159       allocate(ielstart_vdw_nucl(nres))
20160       allocate(ielend_vdw_nucl(nres))
20161
20162       allocate(lentyp(0:nfgtasks-1))
20163 !(0:maxprocs-1)
20164 !----------------------
20165 ! commom.contacts
20166 !      common /contacts/
20167       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
20168       allocate(icont(2,maxcont))
20169 !(2,maxcont)
20170 !      common /contacts1/
20171       allocate(num_cont(0:nres+4))
20172 !(maxres)
20173       allocate(jcont(maxconts,nres))
20174 !(maxconts,maxres)
20175       allocate(facont(maxconts,nres))
20176 !(maxconts,maxres)
20177       allocate(gacont(3,maxconts,nres))
20178 !(3,maxconts,maxres)
20179 !      common /contacts_hb/
20180       allocate(gacontp_hb1(3,maxconts,nres))
20181       allocate(gacontp_hb2(3,maxconts,nres))
20182       allocate(gacontp_hb3(3,maxconts,nres))
20183       allocate(gacontm_hb1(3,maxconts,nres))
20184       allocate(gacontm_hb2(3,maxconts,nres))
20185       allocate(gacontm_hb3(3,maxconts,nres))
20186       allocate(gacont_hbr(3,maxconts,nres))
20187       allocate(grij_hb_cont(3,maxconts,nres))
20188 !(3,maxconts,maxres)
20189       allocate(facont_hb(maxconts,nres))
20190
20191       allocate(ees0p(maxconts,nres))
20192       allocate(ees0m(maxconts,nres))
20193       allocate(d_cont(maxconts,nres))
20194       allocate(ees0plist(maxconts,nres))
20195
20196 !(maxconts,maxres)
20197       allocate(num_cont_hb(nres))
20198 !(maxres)
20199       allocate(jcont_hb(maxconts,nres))
20200 !(maxconts,maxres)
20201 !      common /rotat/
20202       allocate(Ug(2,2,nres))
20203       allocate(Ugder(2,2,nres))
20204       allocate(Ug2(2,2,nres))
20205       allocate(Ug2der(2,2,nres))
20206 !(2,2,maxres)
20207       allocate(obrot(2,nres))
20208       allocate(obrot2(2,nres))
20209       allocate(obrot_der(2,nres))
20210       allocate(obrot2_der(2,nres))
20211 !(2,maxres)
20212 !      common /precomp1/
20213       allocate(mu(2,nres))
20214       allocate(muder(2,nres))
20215       allocate(Ub2(2,nres))
20216       Ub2(1,:)=0.0d0
20217       Ub2(2,:)=0.0d0
20218       allocate(Ub2der(2,nres))
20219       allocate(Ctobr(2,nres))
20220       allocate(Ctobrder(2,nres))
20221       allocate(Dtobr2(2,nres))
20222       allocate(Dtobr2der(2,nres))
20223 !(2,maxres)
20224       allocate(EUg(2,2,nres))
20225       allocate(EUgder(2,2,nres))
20226       allocate(CUg(2,2,nres))
20227       allocate(CUgder(2,2,nres))
20228       allocate(DUg(2,2,nres))
20229       allocate(Dugder(2,2,nres))
20230       allocate(DtUg2(2,2,nres))
20231       allocate(DtUg2der(2,2,nres))
20232 !(2,2,maxres)
20233 !      common /precomp2/
20234       allocate(Ug2Db1t(2,nres))
20235       allocate(Ug2Db1tder(2,nres))
20236       allocate(CUgb2(2,nres))
20237       allocate(CUgb2der(2,nres))
20238 !(2,maxres)
20239       allocate(EUgC(2,2,nres))
20240       allocate(EUgCder(2,2,nres))
20241       allocate(EUgD(2,2,nres))
20242       allocate(EUgDder(2,2,nres))
20243       allocate(DtUg2EUg(2,2,nres))
20244       allocate(Ug2DtEUg(2,2,nres))
20245 !(2,2,maxres)
20246       allocate(Ug2DtEUgder(2,2,2,nres))
20247       allocate(DtUg2EUgder(2,2,2,nres))
20248 !(2,2,2,maxres)
20249       allocate(b1(2,nres))      !(2,-maxtor:maxtor)
20250       allocate(b2(2,nres))      !(2,-maxtor:maxtor)
20251       allocate(b1tilde(2,nres)) !(2,-maxtor:maxtor)
20252       allocate(b2tilde(2,nres)) !(2,-maxtor:maxtor)
20253
20254       allocate(ctilde(2,2,nres))
20255       allocate(dtilde(2,2,nres)) !(2,2,-maxtor:maxtor)
20256       allocate(gtb1(2,nres))
20257       allocate(gtb2(2,nres))
20258       allocate(cc(2,2,nres))
20259       allocate(dd(2,2,nres))
20260       allocate(ee(2,2,nres))
20261       allocate(gtcc(2,2,nres))
20262       allocate(gtdd(2,2,nres))
20263       allocate(gtee(2,2,nres))
20264       allocate(gUb2(2,nres))
20265       allocate(gteUg(2,2,nres))
20266
20267 !      common /rotat_old/
20268       allocate(costab(nres))
20269       allocate(sintab(nres))
20270       allocate(costab2(nres))
20271       allocate(sintab2(nres))
20272 !(maxres)
20273 !      common /dipmat/
20274       allocate(a_chuj(2,2,maxconts,nres))
20275 !(2,2,maxconts,maxres)(maxconts=maxres/4)
20276       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
20277 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
20278 !      common /contdistrib/
20279       allocate(ncont_sent(nres))
20280       allocate(ncont_recv(nres))
20281
20282       allocate(iat_sent(nres))
20283 !(maxres)
20284       allocate(iint_sent(4,nres,nres))
20285       allocate(iint_sent_local(4,nres,nres))
20286 !(4,maxres,maxres)
20287       allocate(iturn3_sent(4,0:nres+4))
20288       allocate(iturn4_sent(4,0:nres+4))
20289       allocate(iturn3_sent_local(4,nres))
20290       allocate(iturn4_sent_local(4,nres))
20291 !(4,maxres)
20292       allocate(itask_cont_from(0:nfgtasks-1))
20293       allocate(itask_cont_to(0:nfgtasks-1))
20294 !(0:max_fg_procs-1)
20295
20296
20297
20298 !----------------------
20299 ! commom.deriv;
20300 !      common /derivat/
20301       allocate(dcdv(6,maxdim))
20302       allocate(dxdv(6,maxdim))
20303 !(6,maxdim)
20304       allocate(dxds(6,nres))
20305 !(6,maxres)
20306       allocate(gradx(3,-1:nres,0:2))
20307       allocate(gradc(3,-1:nres,0:2))
20308 !(3,maxres,2)
20309       allocate(gvdwx(3,-1:nres))
20310       allocate(gvdwc(3,-1:nres))
20311       allocate(gelc(3,-1:nres))
20312       allocate(gelc_long(3,-1:nres))
20313       allocate(gvdwpp(3,-1:nres))
20314       allocate(gvdwc_scpp(3,-1:nres))
20315       allocate(gradx_scp(3,-1:nres))
20316       allocate(gvdwc_scp(3,-1:nres))
20317       allocate(ghpbx(3,-1:nres))
20318       allocate(ghpbc(3,-1:nres))
20319       allocate(gradcorr(3,-1:nres))
20320       allocate(gradcorr_long(3,-1:nres))
20321       allocate(gradcorr5_long(3,-1:nres))
20322       allocate(gradcorr6_long(3,-1:nres))
20323       allocate(gcorr6_turn_long(3,-1:nres))
20324       allocate(gradxorr(3,-1:nres))
20325       allocate(gradcorr5(3,-1:nres))
20326       allocate(gradcorr6(3,-1:nres))
20327       allocate(gliptran(3,-1:nres))
20328       allocate(gliptranc(3,-1:nres))
20329       allocate(gliptranx(3,-1:nres))
20330       allocate(gshieldx(3,-1:nres))
20331       allocate(gshieldc(3,-1:nres))
20332       allocate(gshieldc_loc(3,-1:nres))
20333       allocate(gshieldx_ec(3,-1:nres))
20334       allocate(gshieldc_ec(3,-1:nres))
20335       allocate(gshieldc_loc_ec(3,-1:nres))
20336       allocate(gshieldx_t3(3,-1:nres))
20337       allocate(gshieldc_t3(3,-1:nres))
20338       allocate(gshieldc_loc_t3(3,-1:nres))
20339       allocate(gshieldx_t4(3,-1:nres))
20340       allocate(gshieldc_t4(3,-1:nres))
20341       allocate(gshieldc_loc_t4(3,-1:nres))
20342       allocate(gshieldx_ll(3,-1:nres))
20343       allocate(gshieldc_ll(3,-1:nres))
20344       allocate(gshieldc_loc_ll(3,-1:nres))
20345       allocate(grad_shield(3,-1:nres))
20346       allocate(gg_tube_sc(3,-1:nres))
20347       allocate(gg_tube(3,-1:nres))
20348       allocate(gradafm(3,-1:nres))
20349       allocate(gradb_nucl(3,-1:nres))
20350       allocate(gradbx_nucl(3,-1:nres))
20351       allocate(gvdwpsb1(3,-1:nres))
20352       allocate(gelpp(3,-1:nres))
20353       allocate(gvdwpsb(3,-1:nres))
20354       allocate(gelsbc(3,-1:nres))
20355       allocate(gelsbx(3,-1:nres))
20356       allocate(gvdwsbx(3,-1:nres))
20357       allocate(gvdwsbc(3,-1:nres))
20358       allocate(gsbloc(3,-1:nres))
20359       allocate(gsblocx(3,-1:nres))
20360       allocate(gradcorr_nucl(3,-1:nres))
20361       allocate(gradxorr_nucl(3,-1:nres))
20362       allocate(gradcorr3_nucl(3,-1:nres))
20363       allocate(gradxorr3_nucl(3,-1:nres))
20364       allocate(gvdwpp_nucl(3,-1:nres))
20365       allocate(gradpepcat(3,-1:nres))
20366       allocate(gradpepcatx(3,-1:nres))
20367       allocate(gradcatcat(3,-1:nres))
20368       allocate(gradnuclcat(3,-1:nres))
20369       allocate(gradnuclcatx(3,-1:nres))
20370 !(3,maxres)
20371       allocate(grad_shield_side(3,maxcontsshi,-1:nres))
20372       allocate(grad_shield_loc(3,maxcontsshi,-1:nres))
20373 ! grad for shielding surroing
20374       allocate(gloc(0:maxvar,0:2))
20375       allocate(gloc_x(0:maxvar,2))
20376 !(maxvar,2)
20377       allocate(gel_loc(3,-1:nres))
20378       allocate(gel_loc_long(3,-1:nres))
20379       allocate(gcorr3_turn(3,-1:nres))
20380       allocate(gcorr4_turn(3,-1:nres))
20381       allocate(gcorr6_turn(3,-1:nres))
20382       allocate(gradb(3,-1:nres))
20383       allocate(gradbx(3,-1:nres))
20384 !(3,maxres)
20385       allocate(gel_loc_loc(maxvar))
20386       allocate(gel_loc_turn3(maxvar))
20387       allocate(gel_loc_turn4(maxvar))
20388       allocate(gel_loc_turn6(maxvar))
20389       allocate(gcorr_loc(maxvar))
20390       allocate(g_corr5_loc(maxvar))
20391       allocate(g_corr6_loc(maxvar))
20392 !(maxvar)
20393       allocate(gsccorc(3,-1:nres))
20394       allocate(gsccorx(3,-1:nres))
20395 !(3,maxres)
20396       allocate(gsccor_loc(-1:nres))
20397 !(maxres)
20398       allocate(gvdwx_scbase(3,-1:nres))
20399       allocate(gvdwc_scbase(3,-1:nres))
20400       allocate(gvdwx_pepbase(3,-1:nres))
20401       allocate(gvdwc_pepbase(3,-1:nres))
20402       allocate(gvdwx_scpho(3,-1:nres))
20403       allocate(gvdwc_scpho(3,-1:nres))
20404       allocate(gvdwc_peppho(3,-1:nres))
20405
20406       allocate(dtheta(3,2,-1:nres))
20407 !(3,2,maxres)
20408       allocate(gscloc(3,-1:nres))
20409       allocate(gsclocx(3,-1:nres))
20410 !(3,maxres)
20411       allocate(dphi(3,3,-1:nres))
20412       allocate(dalpha(3,3,-1:nres))
20413       allocate(domega(3,3,-1:nres))
20414 !(3,3,maxres)
20415 !      common /deriv_scloc/
20416       allocate(dXX_C1tab(3,nres))
20417       allocate(dYY_C1tab(3,nres))
20418       allocate(dZZ_C1tab(3,nres))
20419       allocate(dXX_Ctab(3,nres))
20420       allocate(dYY_Ctab(3,nres))
20421       allocate(dZZ_Ctab(3,nres))
20422       allocate(dXX_XYZtab(3,nres))
20423       allocate(dYY_XYZtab(3,nres))
20424       allocate(dZZ_XYZtab(3,nres))
20425 !(3,maxres)
20426 !      common /mpgrad/
20427       allocate(jgrad_start(nres))
20428       allocate(jgrad_end(nres))
20429 !(maxres)
20430 !----------------------
20431
20432 !      common /indices/
20433       allocate(ibond_displ(0:nfgtasks-1))
20434       allocate(ibond_count(0:nfgtasks-1))
20435       allocate(ithet_displ(0:nfgtasks-1))
20436       allocate(ithet_count(0:nfgtasks-1))
20437       allocate(iphi_displ(0:nfgtasks-1))
20438       allocate(iphi_count(0:nfgtasks-1))
20439       allocate(iphi1_displ(0:nfgtasks-1))
20440       allocate(iphi1_count(0:nfgtasks-1))
20441       allocate(ivec_displ(0:nfgtasks-1))
20442       allocate(ivec_count(0:nfgtasks-1))
20443       allocate(iset_displ(0:nfgtasks-1))
20444       allocate(iset_count(0:nfgtasks-1))
20445       allocate(iint_count(0:nfgtasks-1))
20446       allocate(iint_displ(0:nfgtasks-1))
20447 !(0:max_fg_procs-1)
20448 !----------------------
20449 ! common.MD
20450 !      common /mdgrad/
20451       allocate(gcart(3,-1:nres))
20452       allocate(gxcart(3,-1:nres))
20453 !(3,0:MAXRES)
20454       allocate(gradcag(3,-1:nres))
20455       allocate(gradxag(3,-1:nres))
20456 !(3,MAXRES)
20457 !      common /back_constr/
20458 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
20459       allocate(dutheta(nres))
20460       allocate(dugamma(nres))
20461 !(maxres)
20462       allocate(duscdiff(3,nres))
20463       allocate(duscdiffx(3,nres))
20464 !(3,maxres)
20465 !el i io:read_fragments
20466 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
20467 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
20468 !      common /qmeas/
20469 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
20470 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
20471       allocate(mset(0:nprocs))  !(maxprocs/20)
20472       mset(:)=0
20473 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
20474 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
20475       allocate(dUdconst(3,0:nres))
20476       allocate(dUdxconst(3,0:nres))
20477       allocate(dqwol(3,0:nres))
20478       allocate(dxqwol(3,0:nres))
20479 !(3,0:MAXRES)
20480 !----------------------
20481 ! common.sbridge
20482 !      common /sbridge/ in io_common: read_bridge
20483 !el    allocate((:),allocatable :: iss      !(maxss)
20484 !      common /links/  in io_common: read_bridge
20485 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
20486 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
20487 !      common /dyn_ssbond/
20488 ! and side-chain vectors in theta or phi.
20489       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
20490 !(maxres,maxres)
20491 !      do i=1,nres
20492 !        do j=i+1,nres
20493       dyn_ssbond_ij(:,:)=1.0d300
20494 !        enddo
20495 !      enddo
20496
20497 !      if (nss.gt.0) then
20498       allocate(idssb(maxdim),jdssb(maxdim))
20499 !        allocate(newihpb(nss),newjhpb(nss))
20500 !(maxdim)
20501 !      endif
20502       allocate(ishield_list(-1:nres))
20503       allocate(shield_list(maxcontsshi,-1:nres))
20504       allocate(dyn_ss_mask(nres))
20505       allocate(fac_shield(-1:nres))
20506       allocate(enetube(nres*2))
20507       allocate(enecavtube(nres*2))
20508
20509 !(maxres)
20510       dyn_ss_mask(:)=.false.
20511 !----------------------
20512 ! common.sccor
20513 ! Parameters of the SCCOR term
20514 !      common/sccor/
20515 !el in io_conf: parmread
20516 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
20517 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
20518 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
20519 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
20520 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
20521 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
20522 !      allocate(vlor1sccor(maxterm_sccor,20,20))
20523 !      allocate(vlor2sccor(maxterm_sccor,20,20))
20524 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
20525 !----------------
20526       allocate(gloc_sc(3,0:2*nres,0:10))
20527 !(3,0:maxres2,10)maxres2=2*maxres
20528       allocate(dcostau(3,3,3,2*nres))
20529       allocate(dsintau(3,3,3,2*nres))
20530       allocate(dtauangle(3,3,3,2*nres))
20531       allocate(dcosomicron(3,3,3,2*nres))
20532       allocate(domicron(3,3,3,2*nres))
20533 !(3,3,3,maxres2)maxres2=2*maxres
20534 !----------------------
20535 ! common.var
20536 !      common /restr/
20537       allocate(varall(maxvar))
20538 !(maxvar)(maxvar=6*maxres)
20539       allocate(mask_theta(nres))
20540       allocate(mask_phi(nres))
20541       allocate(mask_side(nres))
20542 !(maxres)
20543 !----------------------
20544 ! common.vectors
20545 !      common /vectors/
20546       allocate(uy(3,nres))
20547       allocate(uz(3,nres))
20548 !(3,maxres)
20549       allocate(uygrad(3,3,2,nres))
20550       allocate(uzgrad(3,3,2,nres))
20551 !(3,3,2,maxres)
20552 ! allocateion of lists JPRDLA
20553       allocate(newcontlistppi(300*nres))
20554       allocate(newcontlistscpi(300*nres))
20555       allocate(newcontlisti(300*nres))
20556       allocate(newcontlistppj(300*nres))
20557       allocate(newcontlistscpj(300*nres))
20558       allocate(newcontlistj(300*nres))
20559
20560       return
20561       end subroutine alloc_ener_arrays
20562 !-----------------------------------------------------------------
20563       subroutine ebond_nucl(estr_nucl)
20564 !c
20565 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
20566 !c
20567
20568       real(kind=8),dimension(3) :: u,ud
20569       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
20570       real(kind=8) :: estr_nucl,diff
20571       integer :: iti,i,j,k,nbi
20572       estr_nucl=0.0d0
20573 !C      print *,"I enter ebond"
20574       if (energy_dec) &
20575       write (iout,*) "ibondp_start,ibondp_end",&
20576        ibondp_nucl_start,ibondp_nucl_end
20577       do i=ibondp_nucl_start,ibondp_nucl_end
20578       if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
20579        itype(i,2).eq.ntyp1_molec(2)) cycle
20580 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
20581 !          do j=1,3
20582 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
20583 !     &      *dc(j,i-1)/vbld(i)
20584 !          enddo
20585 !          if (energy_dec) write(iout,*)
20586 !     &       "estr1",i,vbld(i),distchainmax,
20587 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
20588
20589         diff = vbld(i)-vbldp0_nucl
20590         if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
20591         vbldp0_nucl,diff,AKP_nucl*diff*diff
20592         estr_nucl=estr_nucl+diff*diff
20593 !          print *,estr_nucl
20594         do j=1,3
20595           gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
20596         enddo
20597 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
20598       enddo
20599       estr_nucl=0.5d0*AKP_nucl*estr_nucl
20600 !      print *,"partial sum", estr_nucl,AKP_nucl
20601
20602       if (energy_dec) &
20603       write (iout,*) "ibondp_start,ibondp_end",&
20604        ibond_nucl_start,ibond_nucl_end
20605
20606       do i=ibond_nucl_start,ibond_nucl_end
20607 !C        print *, "I am stuck",i
20608       iti=itype(i,2)
20609       if (iti.eq.ntyp1_molec(2)) cycle
20610         nbi=nbondterm_nucl(iti)
20611 !C        print *,iti,nbi
20612         if (nbi.eq.1) then
20613           diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
20614
20615           if (energy_dec) &
20616          write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
20617          AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
20618           estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
20619 !            print *,estr_nucl
20620           do j=1,3
20621             gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
20622           enddo
20623         else
20624           do j=1,nbi
20625             diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
20626             ud(j)=aksc_nucl(j,iti)*diff
20627             u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
20628           enddo
20629           uprod=u(1)
20630           do j=2,nbi
20631             uprod=uprod*u(j)
20632           enddo
20633           usum=0.0d0
20634           usumsqder=0.0d0
20635           do j=1,nbi
20636             uprod1=1.0d0
20637             uprod2=1.0d0
20638             do k=1,nbi
20639             if (k.ne.j) then
20640               uprod1=uprod1*u(k)
20641               uprod2=uprod2*u(k)*u(k)
20642             endif
20643             enddo
20644             usum=usum+uprod1
20645             usumsqder=usumsqder+ud(j)*uprod2
20646           enddo
20647           estr_nucl=estr_nucl+uprod/usum
20648           do j=1,3
20649            gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
20650           enddo
20651       endif
20652       enddo
20653 !C      print *,"I am about to leave ebond"
20654       return
20655       end subroutine ebond_nucl
20656
20657 !-----------------------------------------------------------------------------
20658       subroutine ebend_nucl(etheta_nucl)
20659       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
20660       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
20661       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
20662       logical :: lprn=.false., lprn1=.false.
20663 !el local variables
20664       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
20665       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
20666       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
20667 ! local variables for constrains
20668       real(kind=8) :: difi,thetiii
20669        integer itheta
20670       etheta_nucl=0.0D0
20671 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
20672       do i=ithet_nucl_start,ithet_nucl_end
20673       if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
20674       (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
20675       (itype(i,2).eq.ntyp1_molec(2))) cycle
20676       dethetai=0.0d0
20677       dephii=0.0d0
20678       dephii1=0.0d0
20679       theti2=0.5d0*theta(i)
20680       ityp2=ithetyp_nucl(itype(i-1,2))
20681       do k=1,nntheterm_nucl
20682         coskt(k)=dcos(k*theti2)
20683         sinkt(k)=dsin(k*theti2)
20684       enddo
20685       if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
20686 #ifdef OSF
20687         phii=phi(i)
20688         if (phii.ne.phii) phii=150.0
20689 #else
20690         phii=phi(i)
20691 #endif
20692         ityp1=ithetyp_nucl(itype(i-2,2))
20693         do k=1,nsingle_nucl
20694           cosph1(k)=dcos(k*phii)
20695           sinph1(k)=dsin(k*phii)
20696         enddo
20697       else
20698         phii=0.0d0
20699         ityp1=nthetyp_nucl+1
20700         do k=1,nsingle_nucl
20701           cosph1(k)=0.0d0
20702           sinph1(k)=0.0d0
20703         enddo
20704       endif
20705
20706       if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
20707 #ifdef OSF
20708         phii1=phi(i+1)
20709         if (phii1.ne.phii1) phii1=150.0
20710         phii1=pinorm(phii1)
20711 #else
20712         phii1=phi(i+1)
20713 #endif
20714         ityp3=ithetyp_nucl(itype(i,2))
20715         do k=1,nsingle_nucl
20716           cosph2(k)=dcos(k*phii1)
20717           sinph2(k)=dsin(k*phii1)
20718         enddo
20719       else
20720         phii1=0.0d0
20721         ityp3=nthetyp_nucl+1
20722         do k=1,nsingle_nucl
20723           cosph2(k)=0.0d0
20724           sinph2(k)=0.0d0
20725         enddo
20726       endif
20727       ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
20728       do k=1,ndouble_nucl
20729         do l=1,k-1
20730           ccl=cosph1(l)*cosph2(k-l)
20731           ssl=sinph1(l)*sinph2(k-l)
20732           scl=sinph1(l)*cosph2(k-l)
20733           csl=cosph1(l)*sinph2(k-l)
20734           cosph1ph2(l,k)=ccl-ssl
20735           cosph1ph2(k,l)=ccl+ssl
20736           sinph1ph2(l,k)=scl+csl
20737           sinph1ph2(k,l)=scl-csl
20738         enddo
20739       enddo
20740       if (lprn) then
20741       write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
20742        " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
20743       write (iout,*) "coskt and sinkt",nntheterm_nucl
20744       do k=1,nntheterm_nucl
20745         write (iout,*) k,coskt(k),sinkt(k)
20746       enddo
20747       endif
20748       do k=1,ntheterm_nucl
20749         ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
20750         dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
20751          *coskt(k)
20752         if (lprn)&
20753        write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
20754         " ethetai",ethetai
20755       enddo
20756       if (lprn) then
20757       write (iout,*) "cosph and sinph"
20758       do k=1,nsingle_nucl
20759         write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
20760       enddo
20761       write (iout,*) "cosph1ph2 and sinph2ph2"
20762       do k=2,ndouble_nucl
20763         do l=1,k-1
20764           write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
20765             sinph1ph2(l,k),sinph1ph2(k,l)
20766         enddo
20767       enddo
20768       write(iout,*) "ethetai",ethetai
20769       endif
20770       do m=1,ntheterm2_nucl
20771         do k=1,nsingle_nucl
20772           aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
20773             +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
20774             +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
20775             +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
20776           ethetai=ethetai+sinkt(m)*aux
20777           dethetai=dethetai+0.5d0*m*aux*coskt(m)
20778           dephii=dephii+k*sinkt(m)*(&
20779              ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
20780              bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
20781           dephii1=dephii1+k*sinkt(m)*(&
20782              eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
20783              ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
20784           if (lprn) &
20785          write (iout,*) "m",m," k",k," bbthet",&
20786             bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
20787             ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
20788             ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
20789             eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20790         enddo
20791       enddo
20792       if (lprn) &
20793       write(iout,*) "ethetai",ethetai
20794       do m=1,ntheterm3_nucl
20795         do k=2,ndouble_nucl
20796           do l=1,k-1
20797             aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20798              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
20799              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20800              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
20801             ethetai=ethetai+sinkt(m)*aux
20802             dethetai=dethetai+0.5d0*m*coskt(m)*aux
20803             dephii=dephii+l*sinkt(m)*(&
20804             -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
20805              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20806              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20807              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20808             dephii1=dephii1+(k-l)*sinkt(m)*( &
20809             -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20810              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20811              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
20812              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20813             if (lprn) then
20814             write (iout,*) "m",m," k",k," l",l," ffthet", &
20815              ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
20816              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
20817              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
20818              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20819             write (iout,*) cosph1ph2(l,k)*sinkt(m), &
20820              cosph1ph2(k,l)*sinkt(m),&
20821              sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
20822             endif
20823           enddo
20824         enddo
20825       enddo
20826 10      continue
20827       if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
20828       i,theta(i)*rad2deg,phii*rad2deg, &
20829       phii1*rad2deg,ethetai
20830       etheta_nucl=etheta_nucl+ethetai
20831 !        print *,i,"partial sum",etheta_nucl
20832       if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
20833       if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
20834       gloc(nphi+i-2,icg)=wang_nucl*dethetai
20835       enddo
20836       return
20837       end subroutine ebend_nucl
20838 !----------------------------------------------------
20839       subroutine etor_nucl(etors_nucl)
20840 !      implicit real*8 (a-h,o-z)
20841 !      include 'DIMENSIONS'
20842 !      include 'COMMON.VAR'
20843 !      include 'COMMON.GEO'
20844 !      include 'COMMON.LOCAL'
20845 !      include 'COMMON.TORSION'
20846 !      include 'COMMON.INTERACT'
20847 !      include 'COMMON.DERIV'
20848 !      include 'COMMON.CHAIN'
20849 !      include 'COMMON.NAMES'
20850 !      include 'COMMON.IOUNITS'
20851 !      include 'COMMON.FFIELD'
20852 !      include 'COMMON.TORCNSTR'
20853 !      include 'COMMON.CONTROL'
20854       real(kind=8) :: etors_nucl,edihcnstr
20855       logical :: lprn
20856 !el local variables
20857       integer :: i,j,iblock,itori,itori1
20858       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
20859                vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
20860 ! Set lprn=.true. for debugging
20861       lprn=.false.
20862 !     lprn=.true.
20863       etors_nucl=0.0D0
20864 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
20865       do i=iphi_nucl_start,iphi_nucl_end
20866       if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
20867            .or. itype(i-3,2).eq.ntyp1_molec(2) &
20868            .or. itype(i,2).eq.ntyp1_molec(2)) cycle
20869       etors_ii=0.0D0
20870       itori=itortyp_nucl(itype(i-2,2))
20871       itori1=itortyp_nucl(itype(i-1,2))
20872       phii=phi(i)
20873 !         print *,i,itori,itori1
20874       gloci=0.0D0
20875 !C Regular cosine and sine terms
20876       do j=1,nterm_nucl(itori,itori1)
20877         v1ij=v1_nucl(j,itori,itori1)
20878         v2ij=v2_nucl(j,itori,itori1)
20879         cosphi=dcos(j*phii)
20880         sinphi=dsin(j*phii)
20881         etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
20882         if (energy_dec) etors_ii=etors_ii+&
20883                  v1ij*cosphi+v2ij*sinphi
20884         gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
20885       enddo
20886 !C Lorentz terms
20887 !C                         v1
20888 !C  E = SUM ----------------------------------- - v1
20889 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
20890 !C
20891       cosphi=dcos(0.5d0*phii)
20892       sinphi=dsin(0.5d0*phii)
20893       do j=1,nlor_nucl(itori,itori1)
20894         vl1ij=vlor1_nucl(j,itori,itori1)
20895         vl2ij=vlor2_nucl(j,itori,itori1)
20896         vl3ij=vlor3_nucl(j,itori,itori1)
20897         pom=vl2ij*cosphi+vl3ij*sinphi
20898         pom1=1.0d0/(pom*pom+1.0d0)
20899         etors_nucl=etors_nucl+vl1ij*pom1
20900         if (energy_dec) etors_ii=etors_ii+ &
20901                  vl1ij*pom1
20902         pom=-pom*pom1*pom1
20903         gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
20904       enddo
20905 !C Subtract the constant term
20906       etors_nucl=etors_nucl-v0_nucl(itori,itori1)
20907         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
20908             'etor',i,etors_ii-v0_nucl(itori,itori1)
20909       if (lprn) &
20910        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
20911        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
20912        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
20913       gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
20914 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
20915       enddo
20916       return
20917       end subroutine etor_nucl
20918 !------------------------------------------------------------
20919       subroutine epp_nucl_sub(evdw1,ees)
20920 !C
20921 !C This subroutine calculates the average interaction energy and its gradient
20922 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
20923 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
20924 !C The potential depends both on the distance of peptide-group centers and on
20925 !C the orientation of the CA-CA virtual bonds.
20926 !C
20927       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
20928       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbbi,sslipi,ssgradlipi, &
20929                       sslipj,ssgradlipj,faclipij2
20930       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
20931              dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
20932              dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
20933       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20934                 dist_temp, dist_init,sss_grad,fac,evdw1ij
20935       integer xshift,yshift,zshift
20936       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
20937       real(kind=8) :: ees,eesij
20938 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20939       real(kind=8) scal_el /0.5d0/
20940       t_eelecij=0.0d0
20941       ees=0.0D0
20942       evdw1=0.0D0
20943       ind=0
20944 !c
20945 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
20946 !c
20947 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
20948       do i=iatel_s_nucl,iatel_e_nucl
20949       if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20950       dxi=dc(1,i)
20951       dyi=dc(2,i)
20952       dzi=dc(3,i)
20953       dx_normi=dc_norm(1,i)
20954       dy_normi=dc_norm(2,i)
20955       dz_normi=dc_norm(3,i)
20956       xmedi=c(1,i)+0.5d0*dxi
20957       ymedi=c(2,i)+0.5d0*dyi
20958       zmedi=c(3,i)+0.5d0*dzi
20959         call to_box(xmedi,ymedi,zmedi)
20960         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
20961
20962       do j=ielstart_nucl(i),ielend_nucl(i)
20963         if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
20964         ind=ind+1
20965         dxj=dc(1,j)
20966         dyj=dc(2,j)
20967         dzj=dc(3,j)
20968 !          xj=c(1,j)+0.5D0*dxj-xmedi
20969 !          yj=c(2,j)+0.5D0*dyj-ymedi
20970 !          zj=c(3,j)+0.5D0*dzj-zmedi
20971         xj=c(1,j)+0.5D0*dxj
20972         yj=c(2,j)+0.5D0*dyj
20973         zj=c(3,j)+0.5D0*dzj
20974      call to_box(xj,yj,zj)
20975      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
20976       faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
20977       xj=boxshift(xj-xmedi,boxxsize)
20978       yj=boxshift(yj-ymedi,boxysize)
20979       zj=boxshift(zj-zmedi,boxzsize)
20980         rij=xj*xj+yj*yj+zj*zj
20981 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
20982         fac=(r0pp**2/rij)**3
20983         ev1=epspp*fac*fac
20984         ev2=epspp*fac
20985         evdw1ij=ev1-2*ev2
20986         fac=(-ev1-evdw1ij)/rij
20987 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
20988         if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
20989         evdw1=evdw1+evdw1ij
20990 !C
20991 !C Calculate contributions to the Cartesian gradient.
20992 !C
20993         ggg(1)=fac*xj
20994         ggg(2)=fac*yj
20995         ggg(3)=fac*zj
20996         do k=1,3
20997           gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
20998           gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
20999         enddo
21000 !c phoshate-phosphate electrostatic interactions
21001         rij=dsqrt(rij)
21002         fac=1.0d0/rij
21003         eesij=dexp(-BEES*rij)*fac
21004 !          write (2,*)"fac",fac," eesijpp",eesij
21005         if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
21006         ees=ees+eesij
21007 !c          fac=-eesij*fac
21008         fac=-(fac+BEES)*eesij*fac
21009         ggg(1)=fac*xj
21010         ggg(2)=fac*yj
21011         ggg(3)=fac*zj
21012 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
21013 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
21014 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
21015         do k=1,3
21016           gelpp(k,i)=gelpp(k,i)-ggg(k)
21017           gelpp(k,j)=gelpp(k,j)+ggg(k)
21018         enddo
21019       enddo ! j
21020       enddo   ! i
21021 !c      ees=332.0d0*ees
21022       ees=AEES*ees
21023       do i=nnt,nct
21024 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21025       do k=1,3
21026         gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
21027 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
21028         gelpp(k,i)=AEES*gelpp(k,i)
21029       enddo
21030 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21031       enddo
21032 !c      write (2,*) "total EES",ees
21033       return
21034       end subroutine epp_nucl_sub
21035 !---------------------------------------------------------------------
21036       subroutine epsb(evdwpsb,eelpsb)
21037 !      use comm_locel
21038 !C
21039 !C This subroutine calculates the excluded-volume interaction energy between
21040 !C peptide-group centers and side chains and its gradient in virtual-bond and
21041 !C side-chain vectors.
21042 !C
21043       real(kind=8),dimension(3):: ggg
21044       integer :: i,iint,j,k,iteli,itypj,subchap
21045       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
21046                e1,e2,evdwij,rij,evdwpsb,eelpsb
21047       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21048                 dist_temp, dist_init
21049       integer xshift,yshift,zshift
21050
21051 !cd    print '(a)','Enter ESCP'
21052 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
21053       eelpsb=0.0d0
21054       evdwpsb=0.0d0
21055 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
21056       do i=iatscp_s_nucl,iatscp_e_nucl
21057       if (itype(i,2).eq.ntyp1_molec(2) &
21058        .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21059       xi=0.5D0*(c(1,i)+c(1,i+1))
21060       yi=0.5D0*(c(2,i)+c(2,i+1))
21061       zi=0.5D0*(c(3,i)+c(3,i+1))
21062         call to_box(xi,yi,zi)
21063
21064       do iint=1,nscp_gr_nucl(i)
21065
21066       do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
21067         itypj=itype(j,2)
21068         if (itypj.eq.ntyp1_molec(2)) cycle
21069 !C Uncomment following three lines for SC-p interactions
21070 !c         xj=c(1,nres+j)-xi
21071 !c         yj=c(2,nres+j)-yi
21072 !c         zj=c(3,nres+j)-zi
21073 !C Uncomment following three lines for Ca-p interactions
21074 !          xj=c(1,j)-xi
21075 !          yj=c(2,j)-yi
21076 !          zj=c(3,j)-zi
21077         xj=c(1,j)
21078         yj=c(2,j)
21079         zj=c(3,j)
21080         call to_box(xj,yj,zj)
21081       xj=boxshift(xj-xi,boxxsize)
21082       yj=boxshift(yj-yi,boxysize)
21083       zj=boxshift(zj-zi,boxzsize)
21084
21085       dist_init=xj**2+yj**2+zj**2
21086
21087         rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21088         fac=rrij**expon2
21089         e1=fac*fac*aad_nucl(itypj)
21090         e2=fac*bad_nucl(itypj)
21091         if (iabs(j-i) .le. 2) then
21092           e1=scal14*e1
21093           e2=scal14*e2
21094         endif
21095         evdwij=e1+e2
21096         evdwpsb=evdwpsb+evdwij
21097         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
21098            'evdw2',i,j,evdwij,"tu4"
21099 !C
21100 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
21101 !C
21102         fac=-(evdwij+e1)*rrij
21103         ggg(1)=xj*fac
21104         ggg(2)=yj*fac
21105         ggg(3)=zj*fac
21106         do k=1,3
21107           gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
21108           gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
21109         enddo
21110       enddo
21111
21112       enddo ! iint
21113       enddo ! i
21114       do i=1,nct
21115       do j=1,3
21116         gvdwpsb(j,i)=expon*gvdwpsb(j,i)
21117         gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
21118       enddo
21119       enddo
21120       return
21121       end subroutine epsb
21122
21123 !------------------------------------------------------
21124       subroutine esb_gb(evdwsb,eelsb)
21125       use comm_locel
21126       use calc_data_nucl
21127       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
21128       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
21129       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
21130       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21131                 dist_temp, dist_init,aa,bb,faclip,sig0ij
21132       integer :: ii
21133       logical lprn
21134       evdw=0.0D0
21135       eelsb=0.0d0
21136       ecorr=0.0d0
21137       evdwsb=0.0D0
21138       lprn=.false.
21139       ind=0
21140 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
21141       do i=iatsc_s_nucl,iatsc_e_nucl
21142       num_conti=0
21143       num_conti2=0
21144       itypi=itype(i,2)
21145 !        PRINT *,"I=",i,itypi
21146       if (itypi.eq.ntyp1_molec(2)) cycle
21147       itypi1=itype(i+1,2)
21148       xi=c(1,nres+i)
21149       yi=c(2,nres+i)
21150       zi=c(3,nres+i)
21151       call to_box(xi,yi,zi)
21152       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
21153       dxi=dc_norm(1,nres+i)
21154       dyi=dc_norm(2,nres+i)
21155       dzi=dc_norm(3,nres+i)
21156       dsci_inv=vbld_inv(i+nres)
21157 !C
21158 !C Calculate SC interaction energy.
21159 !C
21160       do iint=1,nint_gr_nucl(i)
21161 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
21162         do j=istart_nucl(i,iint),iend_nucl(i,iint)
21163           ind=ind+1
21164 !            print *,"JESTEM"
21165           itypj=itype(j,2)
21166           if (itypj.eq.ntyp1_molec(2)) cycle
21167           dscj_inv=vbld_inv(j+nres)
21168           sig0ij=sigma_nucl(itypi,itypj)
21169           chi1=chi_nucl(itypi,itypj)
21170           chi2=chi_nucl(itypj,itypi)
21171           chi12=chi1*chi2
21172           chip1=chip_nucl(itypi,itypj)
21173           chip2=chip_nucl(itypj,itypi)
21174           chip12=chip1*chip2
21175 !            xj=c(1,nres+j)-xi
21176 !            yj=c(2,nres+j)-yi
21177 !            zj=c(3,nres+j)-zi
21178          xj=c(1,nres+j)
21179          yj=c(2,nres+j)
21180          zj=c(3,nres+j)
21181      call to_box(xj,yj,zj)
21182 !     call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
21183 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
21184 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
21185 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
21186 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
21187       xj=boxshift(xj-xi,boxxsize)
21188       yj=boxshift(yj-yi,boxysize)
21189       zj=boxshift(zj-zi,boxzsize)
21190
21191           dxj=dc_norm(1,nres+j)
21192           dyj=dc_norm(2,nres+j)
21193           dzj=dc_norm(3,nres+j)
21194           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21195           rij=dsqrt(rrij)
21196 !C Calculate angle-dependent terms of energy and contributions to their
21197 !C derivatives.
21198           erij(1)=xj*rij
21199           erij(2)=yj*rij
21200           erij(3)=zj*rij
21201           om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
21202           om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
21203           om12=dxi*dxj+dyi*dyj+dzi*dzj
21204           call sc_angular_nucl
21205           sigsq=1.0D0/sigsq
21206           sig=sig0ij*dsqrt(sigsq)
21207           rij_shift=1.0D0/rij-sig+sig0ij
21208 !            print *,rij_shift,"rij_shift"
21209 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
21210 !c     &       " rij_shift",rij_shift
21211           if (rij_shift.le.0.0D0) then
21212             evdw=1.0D20
21213             return
21214           endif
21215           sigder=-sig*sigsq
21216 !c---------------------------------------------------------------
21217           rij_shift=1.0D0/rij_shift
21218           fac=rij_shift**expon
21219           e1=fac*fac*aa_nucl(itypi,itypj)
21220           e2=fac*bb_nucl(itypi,itypj)
21221           evdwij=eps1*eps2rt*(e1+e2)
21222 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
21223 !c     &       " e1",e1," e2",e2," evdwij",evdwij
21224           eps2der=evdwij
21225           evdwij=evdwij*eps2rt
21226           evdwsb=evdwsb+evdwij
21227           if (lprn) then
21228           sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
21229           epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
21230           write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
21231            restyp(itypi,2),i,restyp(itypj,2),j, &
21232            epsi,sigm,chi1,chi2,chip1,chip2, &
21233            eps1,eps2rt**2,sig,sig0ij, &
21234            om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
21235           evdwij
21236           write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
21237           endif
21238
21239           if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
21240                        'evdw',i,j,evdwij,"tu3"
21241
21242
21243 !C Calculate gradient components.
21244           e1=e1*eps1*eps2rt**2
21245           fac=-expon*(e1+evdwij)*rij_shift
21246           sigder=fac*sigder
21247           fac=rij*fac
21248 !c            fac=0.0d0
21249 !C Calculate the radial part of the gradient
21250           gg(1)=xj*fac
21251           gg(2)=yj*fac
21252           gg(3)=zj*fac
21253 !C Calculate angular part of the gradient.
21254           call sc_grad_nucl
21255           call eelsbij(eelij,num_conti2)
21256           if (energy_dec .and. &
21257          (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
21258         write (istat,'(e14.5)') evdwij
21259           eelsb=eelsb+eelij
21260         enddo      ! j
21261       enddo        ! iint
21262       num_cont_hb(i)=num_conti2
21263       enddo          ! i
21264 !c      write (iout,*) "Number of loop steps in EGB:",ind
21265 !cccc      energy_dec=.false.
21266       return
21267       end subroutine esb_gb
21268 !-------------------------------------------------------------------------------
21269       subroutine eelsbij(eesij,num_conti2)
21270       use comm_locel
21271       use calc_data_nucl
21272       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
21273       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
21274       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21275                 dist_temp, dist_init,rlocshield,fracinbuf
21276       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
21277
21278 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21279       real(kind=8) scal_el /0.5d0/
21280       integer :: iteli,itelj,kkk,kkll,m,isubchap
21281       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
21282       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
21283       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
21284               r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
21285               el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
21286               ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
21287               a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
21288               ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
21289               ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
21290               ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
21291       ind=ind+1
21292       itypi=itype(i,2)
21293       itypj=itype(j,2)
21294 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
21295       ael6i=ael6_nucl(itypi,itypj)
21296       ael3i=ael3_nucl(itypi,itypj)
21297       ael63i=ael63_nucl(itypi,itypj)
21298       ael32i=ael32_nucl(itypi,itypj)
21299 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
21300 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
21301       dxj=dc(1,j+nres)
21302       dyj=dc(2,j+nres)
21303       dzj=dc(3,j+nres)
21304       dx_normi=dc_norm(1,i+nres)
21305       dy_normi=dc_norm(2,i+nres)
21306       dz_normi=dc_norm(3,i+nres)
21307       dx_normj=dc_norm(1,j+nres)
21308       dy_normj=dc_norm(2,j+nres)
21309       dz_normj=dc_norm(3,j+nres)
21310 !c      xj=c(1,j)+0.5D0*dxj-xmedi
21311 !c      yj=c(2,j)+0.5D0*dyj-ymedi
21312 !c      zj=c(3,j)+0.5D0*dzj-zmedi
21313       if (ipot_nucl.ne.2) then
21314       cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
21315       cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
21316       cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
21317       else
21318       cosa=om12
21319       cosb=om1
21320       cosg=om2
21321       endif
21322       r3ij=rij*rrij
21323       r6ij=r3ij*r3ij
21324       fac=cosa-3.0D0*cosb*cosg
21325       facfac=fac*fac
21326       fac1=3.0d0*(cosb*cosb+cosg*cosg)
21327       fac3=ael6i*r6ij
21328       fac4=ael3i*r3ij
21329       fac5=ael63i*r6ij
21330       fac6=ael32i*r6ij
21331 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
21332 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
21333       el1=fac3*(4.0D0+facfac-fac1)
21334       el2=fac4*fac
21335       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
21336       el4=fac6*facfac
21337       eesij=el1+el2+el3+el4
21338 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
21339       ees0ij=4.0D0+facfac-fac1
21340
21341       if (energy_dec) then
21342         if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
21343         write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
21344          sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
21345          restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
21346          (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
21347         write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
21348       endif
21349
21350 !C
21351 !C Calculate contributions to the Cartesian gradient.
21352 !C
21353       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
21354       fac1=fac
21355 !c      erij(1)=xj*rmij
21356 !c      erij(2)=yj*rmij
21357 !c      erij(3)=zj*rmij
21358 !*
21359 !* Radial derivatives. First process both termini of the fragment (i,j)
21360 !*
21361       ggg(1)=facel*xj
21362       ggg(2)=facel*yj
21363       ggg(3)=facel*zj
21364       do k=1,3
21365       gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21366       gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21367       gelsbx(k,j)=gelsbx(k,j)+ggg(k)
21368       gelsbx(k,i)=gelsbx(k,i)-ggg(k)
21369       enddo
21370 !*
21371 !* Angular part
21372 !*
21373       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
21374       fac4=-3.0D0*fac4
21375       fac3=-6.0D0*fac3
21376       fac5= 6.0d0*fac5
21377       fac6=-6.0d0*fac6
21378       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
21379        fac6*fac1*cosg
21380       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
21381        fac6*fac1*cosb
21382       do k=1,3
21383       dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
21384       dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
21385       enddo
21386       do k=1,3
21387       ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
21388       enddo
21389       do k=1,3
21390       gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
21391            +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
21392            + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21393       gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
21394            +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21395            + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21396       gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21397       gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21398       enddo
21399 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
21400        IF ( j.gt.i+1 .and.&
21401         num_conti.le.maxcont) THEN
21402 !C
21403 !C Calculate the contact function. The ith column of the array JCONT will
21404 !C contain the numbers of atoms that make contacts with the atom I (of numbers
21405 !C greater than I). The arrays FACONT and GACONT will contain the values of
21406 !C the contact function and its derivative.
21407       r0ij=2.20D0*sigma_nucl(itypi,itypj)
21408 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
21409       call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
21410 !c        write (2,*) "fcont",fcont
21411       if (fcont.gt.0.0D0) then
21412         num_conti=num_conti+1
21413         num_conti2=num_conti2+1
21414
21415         if (num_conti.gt.maxconts) then
21416           write (iout,*) 'WARNING - max. # of contacts exceeded;',&
21417                     ' will skip next contacts for this conf.',maxconts
21418         else
21419           jcont_hb(num_conti,i)=j
21420 !c            write (iout,*) "num_conti",num_conti,
21421 !c     &        " jcont_hb",jcont_hb(num_conti,i)
21422 !C Calculate contact energies
21423           cosa4=4.0D0*cosa
21424           wij=cosa-3.0D0*cosb*cosg
21425           cosbg1=cosb+cosg
21426           cosbg2=cosb-cosg
21427           fac3=dsqrt(-ael6i)*r3ij
21428 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
21429           ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
21430           if (ees0tmp.gt.0) then
21431             ees0pij=dsqrt(ees0tmp)
21432           else
21433             ees0pij=0
21434           endif
21435           ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
21436           if (ees0tmp.gt.0) then
21437             ees0mij=dsqrt(ees0tmp)
21438           else
21439             ees0mij=0
21440           endif
21441           ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
21442           ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
21443 !c            write (iout,*) "i",i," j",j,
21444 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
21445           ees0pij1=fac3/ees0pij
21446           ees0mij1=fac3/ees0mij
21447           fac3p=-3.0D0*fac3*rrij
21448           ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
21449           ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
21450           ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
21451           ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
21452           ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
21453           ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
21454           ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
21455           ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
21456           ecosap=ecosa1+ecosa2
21457           ecosbp=ecosb1+ecosb2
21458           ecosgp=ecosg1+ecosg2
21459           ecosam=ecosa1-ecosa2
21460           ecosbm=ecosb1-ecosb2
21461           ecosgm=ecosg1-ecosg2
21462 !C End diagnostics
21463           facont_hb(num_conti,i)=fcont
21464           fprimcont=fprimcont/rij
21465           do k=1,3
21466             gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
21467             gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
21468           enddo
21469           gggp(1)=gggp(1)+ees0pijp*xj
21470           gggp(2)=gggp(2)+ees0pijp*yj
21471           gggp(3)=gggp(3)+ees0pijp*zj
21472           gggm(1)=gggm(1)+ees0mijp*xj
21473           gggm(2)=gggm(2)+ees0mijp*yj
21474           gggm(3)=gggm(3)+ees0mijp*zj
21475 !C Derivatives due to the contact function
21476           gacont_hbr(1,num_conti,i)=fprimcont*xj
21477           gacont_hbr(2,num_conti,i)=fprimcont*yj
21478           gacont_hbr(3,num_conti,i)=fprimcont*zj
21479           do k=1,3
21480 !c
21481 !c Gradient of the correlation terms
21482 !c
21483             gacontp_hb1(k,num_conti,i)= &
21484            (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21485           + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21486             gacontp_hb2(k,num_conti,i)= &
21487            (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
21488           + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21489             gacontp_hb3(k,num_conti,i)=gggp(k)
21490             gacontm_hb1(k,num_conti,i)= &
21491            (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21492           + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21493             gacontm_hb2(k,num_conti,i)= &
21494            (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21495           + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21496             gacontm_hb3(k,num_conti,i)=gggm(k)
21497           enddo
21498         endif
21499       endif
21500       ENDIF
21501       return
21502       end subroutine eelsbij
21503 !------------------------------------------------------------------
21504       subroutine sc_grad_nucl
21505       use comm_locel
21506       use calc_data_nucl
21507       real(kind=8),dimension(3) :: dcosom1,dcosom2
21508       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
21509       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
21510       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
21511       do k=1,3
21512       dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
21513       dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
21514       enddo
21515       do k=1,3
21516       gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
21517       enddo
21518       do k=1,3
21519       gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
21520              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
21521              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
21522       gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
21523              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
21524              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
21525       enddo
21526 !C
21527 !C Calculate the components of the gradient in DC and X
21528 !C
21529       do l=1,3
21530       gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
21531       gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
21532       enddo
21533       return
21534       end subroutine sc_grad_nucl
21535 !-----------------------------------------------------------------------
21536       subroutine esb(esbloc)
21537 !C Calculate the local energy of a side chain and its derivatives in the
21538 !C corresponding virtual-bond valence angles THETA and the spherical angles
21539 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
21540 !C added by Urszula Kozlowska. 07/11/2007
21541 !C
21542       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
21543       real(kind=8),dimension(9):: x
21544      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
21545       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
21546       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
21547       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
21548        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
21549        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
21550        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
21551        integer::it,nlobit,i,j,k
21552 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
21553       delta=0.02d0*pi
21554       esbloc=0.0D0
21555       do i=loc_start_nucl,loc_end_nucl
21556       if (itype(i,2).eq.ntyp1_molec(2)) cycle
21557       costtab(i+1) =dcos(theta(i+1))
21558       sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
21559       cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
21560       sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
21561       cosfac2=0.5d0/(1.0d0+costtab(i+1))
21562       cosfac=dsqrt(cosfac2)
21563       sinfac2=0.5d0/(1.0d0-costtab(i+1))
21564       sinfac=dsqrt(sinfac2)
21565       it=itype(i,2)
21566       if (it.eq.10) goto 1
21567
21568 !c
21569 !C  Compute the axes of tghe local cartesian coordinates system; store in
21570 !c   x_prime, y_prime and z_prime
21571 !c
21572       do j=1,3
21573         x_prime(j) = 0.00
21574         y_prime(j) = 0.00
21575         z_prime(j) = 0.00
21576       enddo
21577 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
21578 !C     &   dc_norm(3,i+nres)
21579       do j = 1,3
21580         x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
21581         y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
21582       enddo
21583       do j = 1,3
21584         z_prime(j) = -uz(j,i-1)
21585 !           z_prime(j)=0.0
21586       enddo
21587
21588       xx=0.0d0
21589       yy=0.0d0
21590       zz=0.0d0
21591       do j = 1,3
21592         xx = xx + x_prime(j)*dc_norm(j,i+nres)
21593         yy = yy + y_prime(j)*dc_norm(j,i+nres)
21594         zz = zz + z_prime(j)*dc_norm(j,i+nres)
21595       enddo
21596
21597       xxtab(i)=xx
21598       yytab(i)=yy
21599       zztab(i)=zz
21600        it=itype(i,2)
21601       do j = 1,9
21602         x(j) = sc_parmin_nucl(j,it)
21603       enddo
21604 #ifdef CHECK_COORD
21605 !Cc diagnostics - remove later
21606       xx1 = dcos(alph(2))
21607       yy1 = dsin(alph(2))*dcos(omeg(2))
21608       zz1 = -dsin(alph(2))*dsin(omeg(2))
21609       write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
21610        alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
21611        xx1,yy1,zz1
21612 !C,"  --- ", xx_w,yy_w,zz_w
21613 !c end diagnostics
21614 #endif
21615       sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21616       esbloc = esbloc + sumene
21617       sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
21618 !        print *,"enecomp",sumene,sumene2
21619 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
21620 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
21621 #ifdef DEBUG
21622       write (2,*) "x",(x(k),k=1,9)
21623 !C
21624 !C This section to check the numerical derivatives of the energy of ith side
21625 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
21626 !C #define DEBUG in the code to turn it on.
21627 !C
21628       write (2,*) "sumene               =",sumene
21629       aincr=1.0d-7
21630       xxsave=xx
21631       xx=xx+aincr
21632       write (2,*) xx,yy,zz
21633       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21634       de_dxx_num=(sumenep-sumene)/aincr
21635       xx=xxsave
21636       write (2,*) "xx+ sumene from enesc=",sumenep,sumene
21637       yysave=yy
21638       yy=yy+aincr
21639       write (2,*) xx,yy,zz
21640       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21641       de_dyy_num=(sumenep-sumene)/aincr
21642       yy=yysave
21643       write (2,*) "yy+ sumene from enesc=",sumenep,sumene
21644       zzsave=zz
21645       zz=zz+aincr
21646       write (2,*) xx,yy,zz
21647       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21648       de_dzz_num=(sumenep-sumene)/aincr
21649       zz=zzsave
21650       write (2,*) "zz+ sumene from enesc=",sumenep,sumene
21651       costsave=cost2tab(i+1)
21652       sintsave=sint2tab(i+1)
21653       cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
21654       sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
21655       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21656       de_dt_num=(sumenep-sumene)/aincr
21657       write (2,*) " t+ sumene from enesc=",sumenep,sumene
21658       cost2tab(i+1)=costsave
21659       sint2tab(i+1)=sintsave
21660 !C End of diagnostics section.
21661 #endif
21662 !C
21663 !C Compute the gradient of esc
21664 !C
21665       de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
21666       de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
21667       de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
21668       de_dtt=0.0d0
21669 #ifdef DEBUG
21670       write (2,*) "x",(x(k),k=1,9)
21671       write (2,*) "xx",xx," yy",yy," zz",zz
21672       write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
21673         " de_zz   ",de_zz," de_tt   ",de_tt
21674       write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
21675         " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
21676 #endif
21677 !C
21678        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
21679        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
21680        cosfac2xx=cosfac2*xx
21681        sinfac2yy=sinfac2*yy
21682        do k = 1,3
21683        dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
21684          vbld_inv(i+1)
21685        dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
21686          vbld_inv(i)
21687        pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
21688        pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
21689 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
21690 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
21691 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
21692 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
21693        dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
21694        dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
21695        dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
21696        dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
21697        dZZ_Ci1(k)=0.0d0
21698        dZZ_Ci(k)=0.0d0
21699        do j=1,3
21700          dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
21701          dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
21702        enddo
21703
21704        dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
21705        dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
21706        dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
21707 !c
21708        dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
21709        dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
21710        enddo
21711
21712        do k=1,3
21713        dXX_Ctab(k,i)=dXX_Ci(k)
21714        dXX_C1tab(k,i)=dXX_Ci1(k)
21715        dYY_Ctab(k,i)=dYY_Ci(k)
21716        dYY_C1tab(k,i)=dYY_Ci1(k)
21717        dZZ_Ctab(k,i)=dZZ_Ci(k)
21718        dZZ_C1tab(k,i)=dZZ_Ci1(k)
21719        dXX_XYZtab(k,i)=dXX_XYZ(k)
21720        dYY_XYZtab(k,i)=dYY_XYZ(k)
21721        dZZ_XYZtab(k,i)=dZZ_XYZ(k)
21722        enddo
21723        do k = 1,3
21724 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
21725 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
21726 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
21727 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
21728 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
21729 !c     &    dt_dci(k)
21730 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
21731 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
21732        gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
21733        +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
21734        gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
21735        +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
21736        gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
21737        +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
21738 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
21739        enddo
21740 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
21741 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
21742
21743 !C to check gradient call subroutine check_grad
21744
21745     1 continue
21746       enddo
21747       return
21748       end subroutine esb
21749 !=-------------------------------------------------------
21750       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
21751 !      implicit none
21752       real(kind=8),dimension(9):: x(9)
21753        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
21754       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
21755       integer i
21756 !c      write (2,*) "enesc"
21757 !c      write (2,*) "x",(x(i),i=1,9)
21758 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
21759       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
21760       + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
21761       + x(9)*yy*zz
21762       enesc_nucl=sumene
21763       return
21764       end function enesc_nucl
21765 !-----------------------------------------------------------------------------
21766       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
21767 #ifdef MPI
21768       include 'mpif.h'
21769       integer,parameter :: max_cont=2000
21770       integer,parameter:: max_dim=2*(8*3+6)
21771       integer, parameter :: msglen1=max_cont*max_dim
21772       integer,parameter :: msglen2=2*msglen1
21773       integer source,CorrelType,CorrelID,Error
21774       real(kind=8) :: buffer(max_cont,max_dim)
21775       integer status(MPI_STATUS_SIZE)
21776       integer :: ierror,nbytes
21777 #endif
21778       real(kind=8),dimension(3):: gx(3),gx1(3)
21779       real(kind=8) :: time00
21780       logical lprn,ldone
21781       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
21782       real(kind=8) ecorr,ecorr3
21783       integer :: n_corr,n_corr1,mm,msglen
21784 !C Set lprn=.true. for debugging
21785       lprn=.false.
21786       n_corr=0
21787       n_corr1=0
21788 #ifdef MPI
21789       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
21790
21791       if (nfgtasks.le.1) goto 30
21792       if (lprn) then
21793       write (iout,'(a)') 'Contact function values:'
21794       do i=nnt,nct-1
21795         write (iout,'(2i3,50(1x,i2,f5.2))')  &
21796        i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21797        j=1,num_cont_hb(i))
21798       enddo
21799       endif
21800 !C Caution! Following code assumes that electrostatic interactions concerning
21801 !C a given atom are split among at most two processors!
21802       CorrelType=477
21803       CorrelID=fg_rank+1
21804       ldone=.false.
21805       do i=1,max_cont
21806       do j=1,max_dim
21807         buffer(i,j)=0.0D0
21808       enddo
21809       enddo
21810       mm=mod(fg_rank,2)
21811 !c      write (*,*) 'MyRank',MyRank,' mm',mm
21812       if (mm) 20,20,10
21813    10 continue
21814 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
21815       if (fg_rank.gt.0) then
21816 !C Send correlation contributions to the preceding processor
21817       msglen=msglen1
21818       nn=num_cont_hb(iatel_s_nucl)
21819       call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
21820 !c        write (*,*) 'The BUFFER array:'
21821 !c        do i=1,nn
21822 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
21823 !c        enddo
21824       if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
21825         msglen=msglen2
21826         call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
21827 !C Clear the contacts of the atom passed to the neighboring processor
21828       nn=num_cont_hb(iatel_s_nucl+1)
21829 !c        do i=1,nn
21830 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
21831 !c        enddo
21832           num_cont_hb(iatel_s_nucl)=0
21833       endif
21834 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
21835 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
21836 !cd   & ' msglen=',msglen
21837 !c        write (*,*) 'Processor ',fg_rank,MyRank,
21838 !c     & ' is sending correlation contribution to processor',fg_rank-1,
21839 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21840       time00=MPI_Wtime()
21841       call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
21842        CorrelType,FG_COMM,IERROR)
21843       time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21844 !cd      write (iout,*) 'Processor ',fg_rank,
21845 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
21846 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
21847 !c        write (*,*) 'Processor ',fg_rank,
21848 !c     & ' has sent correlation contribution to processor',fg_rank-1,
21849 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
21850 !c        msglen=msglen1
21851       endif ! (fg_rank.gt.0)
21852       if (ldone) goto 30
21853       ldone=.true.
21854    20 continue
21855 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
21856       if (fg_rank.lt.nfgtasks-1) then
21857 !C Receive correlation contributions from the next processor
21858       msglen=msglen1
21859       if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
21860 !cd      write (iout,*) 'Processor',fg_rank,
21861 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
21862 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
21863 !c        write (*,*) 'Processor',fg_rank,
21864 !c     &' is receiving correlation contribution from processor',fg_rank+1,
21865 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21866       time00=MPI_Wtime()
21867       nbytes=-1
21868       do while (nbytes.le.0)
21869         call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21870         call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
21871       enddo
21872 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
21873       call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
21874        fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21875       time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21876 !c        write (*,*) 'Processor',fg_rank,
21877 !c     &' has received correlation contribution from processor',fg_rank+1,
21878 !c     & ' msglen=',msglen,' nbytes=',nbytes
21879 !c        write (*,*) 'The received BUFFER array:'
21880 !c        do i=1,max_cont
21881 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
21882 !c        enddo
21883       if (msglen.eq.msglen1) then
21884         call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
21885       else if (msglen.eq.msglen2)  then
21886         call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
21887         call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
21888       else
21889         write (iout,*) &
21890       'ERROR!!!! message length changed while processing correlations.'
21891         write (*,*) &
21892       'ERROR!!!! message length changed while processing correlations.'
21893         call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
21894       endif ! msglen.eq.msglen1
21895       endif ! fg_rank.lt.nfgtasks-1
21896       if (ldone) goto 30
21897       ldone=.true.
21898       goto 10
21899    30 continue
21900 #endif
21901       if (lprn) then
21902       write (iout,'(a)') 'Contact function values:'
21903       do i=nnt_molec(2),nct_molec(2)-1
21904         write (iout,'(2i3,50(1x,i2,f5.2))') &
21905        i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21906        j=1,num_cont_hb(i))
21907       enddo
21908       endif
21909       ecorr=0.0D0
21910       ecorr3=0.0d0
21911 !C Remove the loop below after debugging !!!
21912 !      do i=nnt_molec(2),nct_molec(2)
21913 !        do j=1,3
21914 !          gradcorr_nucl(j,i)=0.0D0
21915 !          gradxorr_nucl(j,i)=0.0D0
21916 !          gradcorr3_nucl(j,i)=0.0D0
21917 !          gradxorr3_nucl(j,i)=0.0D0
21918 !        enddo
21919 !      enddo
21920 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
21921 !C Calculate the local-electrostatic correlation terms
21922       do i=iatsc_s_nucl,iatsc_e_nucl
21923       i1=i+1
21924       num_conti=num_cont_hb(i)
21925       num_conti1=num_cont_hb(i+1)
21926 !        print *,i,num_conti,num_conti1
21927       do jj=1,num_conti
21928         j=jcont_hb(jj,i)
21929         do kk=1,num_conti1
21930           j1=jcont_hb(kk,i1)
21931 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
21932 !c     &         ' jj=',jj,' kk=',kk
21933           if (j1.eq.j+1 .or. j1.eq.j-1) then
21934 !C
21935 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
21936 !C The system gains extra energy.
21937 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
21938 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21939 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
21940 !C
21941             ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21942             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
21943              'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21944             n_corr=n_corr+1
21945           else if (j1.eq.j) then
21946 !C
21947 !C Contacts I-J and I-(J+1) occur simultaneously.
21948 !C The system loses extra energy.
21949 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
21950 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21951 !C Need to implement full formulas 32 from Liwo et al., 1998.
21952 !C
21953 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21954 !c     &         ' jj=',jj,' kk=',kk
21955             ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
21956           endif
21957         enddo ! kk
21958         do kk=1,num_conti
21959           j1=jcont_hb(kk,i)
21960 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21961 !c     &         ' jj=',jj,' kk=',kk
21962           if (j1.eq.j+1) then
21963 !C Contacts I-J and (I+1)-J occur simultaneously.
21964 !C The system loses extra energy.
21965             ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
21966           endif ! j1==j+1
21967         enddo ! kk
21968       enddo ! jj
21969       enddo ! i
21970       return
21971       end subroutine multibody_hb_nucl
21972 !-----------------------------------------------------------
21973       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21974 !      implicit real*8 (a-h,o-z)
21975 !      include 'DIMENSIONS'
21976 !      include 'COMMON.IOUNITS'
21977 !      include 'COMMON.DERIV'
21978 !      include 'COMMON.INTERACT'
21979 !      include 'COMMON.CONTACTS'
21980       real(kind=8),dimension(3) :: gx,gx1
21981       logical :: lprn
21982 !el local variables
21983       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21984       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21985                ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21986                coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21987                rlocshield
21988
21989       lprn=.false.
21990       eij=facont_hb(jj,i)
21991       ekl=facont_hb(kk,k)
21992       ees0pij=ees0p(jj,i)
21993       ees0pkl=ees0p(kk,k)
21994       ees0mij=ees0m(jj,i)
21995       ees0mkl=ees0m(kk,k)
21996       ekont=eij*ekl
21997       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21998 !      print *,"ehbcorr_nucl",ekont,ees
21999 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22000 !C Following 4 lines for diagnostics.
22001 !cd    ees0pkl=0.0D0
22002 !cd    ees0pij=1.0D0
22003 !cd    ees0mkl=0.0D0
22004 !cd    ees0mij=1.0D0
22005 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22006 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22007 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22008 !C Calculate the multi-body contribution to energy.
22009 !      ecorr_nucl=ecorr_nucl+ekont*ees
22010 !C Calculate multi-body contributions to the gradient.
22011       coeffpees0pij=coeffp*ees0pij
22012       coeffmees0mij=coeffm*ees0mij
22013       coeffpees0pkl=coeffp*ees0pkl
22014       coeffmees0mkl=coeffm*ees0mkl
22015       do ll=1,3
22016       gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
22017        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22018        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22019       gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
22020       -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
22021       coeffmees0mkl*gacontm_hb2(ll,jj,i))
22022       gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
22023       -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
22024       coeffmees0mij*gacontm_hb1(ll,kk,k))
22025       gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
22026       -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22027       coeffmees0mij*gacontm_hb2(ll,kk,k))
22028       gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22029         ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22030         coeffmees0mkl*gacontm_hb3(ll,jj,i))
22031       gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
22032       gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
22033       gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22034         ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22035         coeffmees0mij*gacontm_hb3(ll,kk,k))
22036       gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
22037       gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
22038       gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
22039       gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
22040       gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
22041       gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
22042       enddo
22043       ehbcorr_nucl=ekont*ees
22044       return
22045       end function ehbcorr_nucl
22046 !-------------------------------------------------------------------------
22047
22048      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22049 !      implicit real*8 (a-h,o-z)
22050 !      include 'DIMENSIONS'
22051 !      include 'COMMON.IOUNITS'
22052 !      include 'COMMON.DERIV'
22053 !      include 'COMMON.INTERACT'
22054 !      include 'COMMON.CONTACTS'
22055       real(kind=8),dimension(3) :: gx,gx1
22056       logical :: lprn
22057 !el local variables
22058       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22059       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22060                ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22061                coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22062                rlocshield
22063
22064       lprn=.false.
22065       eij=facont_hb(jj,i)
22066       ekl=facont_hb(kk,k)
22067       ees0pij=ees0p(jj,i)
22068       ees0pkl=ees0p(kk,k)
22069       ees0mij=ees0m(jj,i)
22070       ees0mkl=ees0m(kk,k)
22071       ekont=eij*ekl
22072       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22073 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22074 !C Following 4 lines for diagnostics.
22075 !cd    ees0pkl=0.0D0
22076 !cd    ees0pij=1.0D0
22077 !cd    ees0mkl=0.0D0
22078 !cd    ees0mij=1.0D0
22079 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22080 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22081 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22082 !C Calculate the multi-body contribution to energy.
22083 !      ecorr=ecorr+ekont*ees
22084 !C Calculate multi-body contributions to the gradient.
22085       coeffpees0pij=coeffp*ees0pij
22086       coeffmees0mij=coeffm*ees0mij
22087       coeffpees0pkl=coeffp*ees0pkl
22088       coeffmees0mkl=coeffm*ees0mkl
22089       do ll=1,3
22090       gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
22091        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22092        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22093       gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
22094       -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
22095       coeffmees0mkl*gacontm_hb2(ll,jj,i))
22096       gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
22097       -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
22098       coeffmees0mij*gacontm_hb1(ll,kk,k))
22099       gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
22100       -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22101       coeffmees0mij*gacontm_hb2(ll,kk,k))
22102       gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22103         ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22104         coeffmees0mkl*gacontm_hb3(ll,jj,i))
22105       gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
22106       gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
22107       gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22108         ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22109         coeffmees0mij*gacontm_hb3(ll,kk,k))
22110       gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
22111       gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
22112       gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
22113       gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
22114       gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
22115       gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
22116       enddo
22117       ehbcorr3_nucl=ekont*ees
22118       return
22119       end function ehbcorr3_nucl
22120 #ifdef MPI
22121       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
22122       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22123       real(kind=8):: buffer(dimen1,dimen2)
22124       num_kont=num_cont_hb(atom)
22125       do i=1,num_kont
22126       do k=1,8
22127         do j=1,3
22128           buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
22129         enddo ! j
22130       enddo ! k
22131       buffer(i,indx+25)=facont_hb(i,atom)
22132       buffer(i,indx+26)=ees0p(i,atom)
22133       buffer(i,indx+27)=ees0m(i,atom)
22134       buffer(i,indx+28)=d_cont(i,atom)
22135       buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
22136       enddo ! i
22137       buffer(1,indx+30)=dfloat(num_kont)
22138       return
22139       end subroutine pack_buffer
22140 !c------------------------------------------------------------------------------
22141       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
22142       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22143       real(kind=8):: buffer(dimen1,dimen2)
22144 !      double precision zapas
22145 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
22146 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
22147 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
22148 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
22149       num_kont=buffer(1,indx+30)
22150       num_kont_old=num_cont_hb(atom)
22151       num_cont_hb(atom)=num_kont+num_kont_old
22152       do i=1,num_kont
22153       ii=i+num_kont_old
22154       do k=1,8
22155         do j=1,3
22156           zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
22157         enddo ! j
22158       enddo ! k
22159       facont_hb(ii,atom)=buffer(i,indx+25)
22160       ees0p(ii,atom)=buffer(i,indx+26)
22161       ees0m(ii,atom)=buffer(i,indx+27)
22162       d_cont(i,atom)=buffer(i,indx+28)
22163       jcont_hb(ii,atom)=buffer(i,indx+29)
22164       enddo ! i
22165       return
22166       end subroutine unpack_buffer
22167 !c------------------------------------------------------------------------------
22168 #endif
22169       subroutine ecatcat(ecationcation)
22170       integer :: i,j,itmp,xshift,yshift,zshift,subchap,k,itypi,itypj
22171       real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22172       r7,r4,ecationcation,k0,rcal,aa,bb,sslipi,ssgradlipi,sslipj,ssgradlipj
22173       real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22174       dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
22175       real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22176       gg,r
22177
22178       ecationcation=0.0d0
22179       if (nres_molec(5).eq.0) return
22180       rcat0=3.472
22181       epscalc=0.05
22182       r06 = rcat0**6
22183       r012 = r06**2
22184 !        k0 = 332.0*(2.0*2.0)/80.0
22185       itmp=0
22186
22187       do i=1,4
22188       itmp=itmp+nres_molec(i)
22189       enddo
22190 !        write(iout,*) "itmp",itmp
22191       do i=itmp+1,itmp+nres_molec(5)-1
22192
22193       xi=c(1,i)
22194       yi=c(2,i)
22195       zi=c(3,i)
22196 !        write (iout,*) i,"TUTUT",c(1,i)
22197         itypi=itype(i,5)
22198       call to_box(xi,yi,zi)
22199       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
22200         do j=i+1,itmp+nres_molec(5)
22201         itypj=itype(j,5)
22202 !          print *,i,j,itypi,itypj
22203         k0 = 332.0*(ichargecat(itypi)*ichargecat(itypj))/80.0
22204 !           print *,i,j,'catcat'
22205          xj=c(1,j)
22206          yj=c(2,j)
22207          zj=c(3,j)
22208       call to_box(xj,yj,zj)
22209 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
22210 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22211 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22212 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22213 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22214       xj=boxshift(xj-xi,boxxsize)
22215       yj=boxshift(yj-yi,boxysize)
22216       zj=boxshift(zj-zi,boxzsize)
22217        rcal =xj**2+yj**2+zj**2
22218       ract=sqrt(rcal)
22219 !        rcat0=3.472
22220 !        epscalc=0.05
22221 !        r06 = rcat0**6
22222 !        r012 = r06**2
22223 !        k0 = 332*(2*2)/80
22224       Evan1cat=epscalc*(r012/(rcal**6))
22225       Evan2cat=epscalc*2*(r06/(rcal**3))
22226       Eeleccat=k0/ract
22227       r7 = rcal**7
22228       r4 = rcal**4
22229       r(1)=xj
22230       r(2)=yj
22231       r(3)=zj
22232       do k=1,3
22233         dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
22234         dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
22235         dEeleccat(k)=-k0*r(k)/ract**3
22236       enddo
22237       do k=1,3
22238         gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
22239         gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
22240         gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
22241       enddo
22242       if (energy_dec) write (iout,*) i,j,Evan1cat,Evan2cat,Eeleccat,&
22243        r012,rcal**6,ichargecat(itypi)*ichargecat(itypj)
22244 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
22245       ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
22246        enddo
22247        enddo
22248        return
22249        end subroutine ecatcat
22250 !---------------------------------------------------------------------------
22251 ! new for K+
22252       subroutine ecats_prot_amber(evdw)
22253 !      subroutine ecat_prot2(ecation_prot)
22254       use calc_data
22255       use comm_momo
22256
22257       logical :: lprn
22258 !el local variables
22259       integer :: iint,itypi1,subchap,isel,itmp
22260       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
22261       real(kind=8) :: evdw,aa,bb
22262       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22263                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
22264                 sslipi,sslipj,faclip,alpha_sco
22265       integer :: ii
22266       real(kind=8) :: fracinbuf
22267       real (kind=8) :: escpho
22268       real (kind=8),dimension(4):: ener
22269       real(kind=8) :: b1,b2,egb
22270       real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
22271        Lambf,&
22272        Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
22273        ecations_prot_amber,dFdOM2,dFdL,dFdOM12,&
22274        federmaus,&
22275        d1i,d1j
22276 !       real(kind=8),dimension(3,2)::erhead_tail
22277 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
22278       real(kind=8) ::  facd4, adler, Fgb, facd3
22279       integer troll,jj,istate
22280       real (kind=8) :: dcosom1(3),dcosom2(3)
22281
22282       evdw=0.0D0
22283       if (nres_molec(5).eq.0) return
22284       eps_out=80.0d0
22285 !      sss_ele_cut=1.0d0
22286
22287       itmp=0
22288       do i=1,4
22289       itmp=itmp+nres_molec(i)
22290       enddo
22291 !        go to 17
22292 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
22293       do i=ibond_start,ibond_end
22294
22295 !        print *,"I am in EVDW",i
22296       itypi=iabs(itype(i,1))
22297
22298 !        if (i.ne.47) cycle
22299       if ((itypi.eq.ntyp1).or.(itypi.eq.10)) cycle
22300       itypi1=iabs(itype(i+1,1))
22301       xi=c(1,nres+i)
22302       yi=c(2,nres+i)
22303       zi=c(3,nres+i)
22304       call to_box(xi,yi,zi)
22305       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
22306       dxi=dc_norm(1,nres+i)
22307       dyi=dc_norm(2,nres+i)
22308       dzi=dc_norm(3,nres+i)
22309       dsci_inv=vbld_inv(i+nres)
22310        do j=itmp+1,itmp+nres_molec(5)
22311
22312 ! Calculate SC interaction energy.
22313           itypj=iabs(itype(j,5))
22314           if ((itypj.eq.ntyp1)) cycle
22315            CALL elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
22316
22317           dscj_inv=0.0
22318          xj=c(1,j)
22319          yj=c(2,j)
22320          zj=c(3,j)
22321
22322       call to_box(xj,yj,zj)
22323 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
22324 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22325 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22326 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22327 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22328       xj=boxshift(xj-xi,boxxsize)
22329       yj=boxshift(yj-yi,boxysize)
22330       zj=boxshift(zj-zi,boxzsize)
22331
22332 !          dxj = dc_norm( 1, nres+j )
22333 !          dyj = dc_norm( 2, nres+j )
22334 !          dzj = dc_norm( 3, nres+j )
22335
22336         itypi = itype(i,1)
22337         itypj = itype(j,5)
22338 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
22339 ! sampling performed with amber package
22340 !          alf1   = 0.0d0
22341 !          alf2   = 0.0d0
22342 !          alf12  = 0.0d0
22343 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
22344         chi1 = chi1cat(itypi,itypj)
22345         chis1 = chis1cat(itypi,itypj)
22346         chip1 = chipp1cat(itypi,itypj)
22347 !          chi1=0.0d0
22348 !          chis1=0.0d0
22349 !          chip1=0.0d0
22350         chi2=0.0
22351         chip2=0.0
22352         chis2=0.0
22353 !          chis2 = chis(itypj,itypi)
22354         chis12 = chis1 * chis2
22355         sig1 = sigmap1cat(itypi,itypj)
22356 !          sig2 = sigmap2(itypi,itypj)
22357 ! alpha factors from Fcav/Gcav
22358         b1cav = alphasurcat(1,itypi,itypj)
22359         b2cav = alphasurcat(2,itypi,itypj)
22360         b3cav = alphasurcat(3,itypi,itypj)
22361         b4cav = alphasurcat(4,itypi,itypj)
22362
22363 ! used to determine whether we want to do quadrupole calculations
22364        eps_in = epsintabcat(itypi,itypj)
22365        if (eps_in.eq.0.0) eps_in=1.0
22366
22367        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
22368 !       Rtail = 0.0d0
22369
22370        DO k = 1, 3
22371       ctail(k,1)=c(k,i+nres)
22372       ctail(k,2)=c(k,j)
22373        END DO
22374 !c! tail distances will be themselves usefull elswhere
22375 !c1 (in Gcav, for example)
22376        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
22377        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
22378        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
22379        Rtail = dsqrt( &
22380         (Rtail_distance(1)*Rtail_distance(1)) &
22381       + (Rtail_distance(2)*Rtail_distance(2)) &
22382       + (Rtail_distance(3)*Rtail_distance(3)))
22383 ! tail location and distance calculations
22384 ! dhead1
22385        d1 = dheadcat(1, 1, itypi, itypj)
22386 !       d2 = dhead(2, 1, itypi, itypj)
22387        DO k = 1,3
22388 ! location of polar head is computed by taking hydrophobic centre
22389 ! and moving by a d1 * dc_norm vector
22390 ! see unres publications for very informative images
22391       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
22392       chead(k,2) = c(k, j)
22393 ! distance
22394 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22395 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22396       Rhead_distance(k) = chead(k,2) - chead(k,1)
22397        END DO
22398 ! pitagoras (root of sum of squares)
22399        Rhead = dsqrt( &
22400         (Rhead_distance(1)*Rhead_distance(1)) &
22401       + (Rhead_distance(2)*Rhead_distance(2)) &
22402       + (Rhead_distance(3)*Rhead_distance(3)))
22403 !-------------------------------------------------------------------
22404 ! zero everything that should be zero'ed
22405        evdwij = 0.0d0
22406        ECL = 0.0d0
22407        Elj = 0.0d0
22408        Equad = 0.0d0
22409        Epol = 0.0d0
22410        Fcav=0.0d0
22411        eheadtail = 0.0d0
22412        dGCLdOM1 = 0.0d0
22413        dGCLdOM2 = 0.0d0
22414        dGCLdOM12 = 0.0d0
22415        dPOLdOM1 = 0.0d0
22416        dPOLdOM2 = 0.0d0
22417         Fcav = 0.0d0
22418         dFdR = 0.0d0
22419         dCAVdOM1  = 0.0d0
22420         dCAVdOM2  = 0.0d0
22421         dCAVdOM12 = 0.0d0
22422         dscj_inv = vbld_inv(j+nres)
22423 !          print *,i,j,dscj_inv,dsci_inv
22424 ! rij holds 1/(distance of Calpha atoms)
22425         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
22426         rij  = dsqrt(rrij)
22427         CALL sc_angular
22428 ! this should be in elgrad_init but om's are calculated by sc_angular
22429 ! which in turn is used by older potentials
22430 ! om = omega, sqom = om^2
22431         sqom1  = om1 * om1
22432         sqom2  = om2 * om2
22433         sqom12 = om12 * om12
22434
22435 ! now we calculate EGB - Gey-Berne
22436 ! It will be summed up in evdwij and saved in evdw
22437         sigsq     = 1.0D0  / sigsq
22438         sig       = sig0ij * dsqrt(sigsq)
22439 !          rij_shift = 1.0D0  / rij - sig + sig0ij
22440         rij_shift = Rtail - sig + sig0ij
22441         IF (rij_shift.le.0.0D0) THEN
22442          evdw = 1.0D20
22443          RETURN
22444         END IF
22445         sigder = -sig * sigsq
22446         rij_shift = 1.0D0 / rij_shift
22447         fac       = rij_shift**expon
22448         c1        = fac  * fac * aa_aq_cat(itypi,itypj)
22449 !          print *,"ADAM",aa_aq(itypi,itypj)
22450
22451 !          c1        = 0.0d0
22452         c2        = fac  * bb_aq_cat(itypi,itypj)
22453 !          c2        = 0.0d0
22454         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
22455         eps2der   = eps3rt * evdwij
22456         eps3der   = eps2rt * evdwij
22457 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
22458         evdwij    = eps2rt * eps3rt * evdwij
22459 !#ifdef TSCSC
22460 !          IF (bb_aq(itypi,itypj).gt.0) THEN
22461 !           evdw_p = evdw_p + evdwij
22462 !          ELSE
22463 !           evdw_m = evdw_m + evdwij
22464 !          END IF
22465 !#else
22466         evdw = evdw  &
22467             + evdwij
22468 !#endif
22469         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
22470         fac    = -expon * (c1 + evdwij) * rij_shift
22471         sigder = fac * sigder
22472 ! Calculate distance derivative
22473         gg(1) =  fac
22474         gg(2) =  fac
22475         gg(3) =  fac
22476
22477         fac = chis1 * sqom1 + chis2 * sqom2 &
22478         - 2.0d0 * chis12 * om1 * om2 * om12
22479         pom = 1.0d0 - chis1 * chis2 * sqom12
22480         Lambf = (1.0d0 - (fac / pom))
22481         Lambf = dsqrt(Lambf)
22482         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
22483         Chif = Rtail * sparrow
22484         ChiLambf = Chif * Lambf
22485         eagle = dsqrt(ChiLambf)
22486         bat = ChiLambf ** 11.0d0
22487         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
22488         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
22489         botsq = bot * bot
22490         Fcav = top / bot
22491
22492        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
22493        dbot = 12.0d0 * b4cav * bat * Lambf
22494        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
22495
22496         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
22497         dbot = 12.0d0 * b4cav * bat * Chif
22498         eagle = Lambf * pom
22499         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
22500         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
22501         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
22502             * (chis2 * om2 * om12 - om1) / (eagle * pom)
22503
22504         dFdL = ((dtop * bot - top * dbot) / botsq)
22505         dCAVdOM1  = dFdL * ( dFdOM1 )
22506         dCAVdOM2  = dFdL * ( dFdOM2 )
22507         dCAVdOM12 = dFdL * ( dFdOM12 )
22508
22509        DO k= 1, 3
22510       ertail(k) = Rtail_distance(k)/Rtail
22511        END DO
22512        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
22513        erdxj = scalar( ertail(1), dC_norm(1,j) )
22514        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
22515        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j+nres)
22516        DO k = 1, 3
22517       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
22518       gradpepcatx(k,i) = gradpepcatx(k,i) &
22519               - (( dFdR + gg(k) ) * pom)
22520       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
22521 !        gvdwx(k,j) = gvdwx(k,j)   &
22522 !                  + (( dFdR + gg(k) ) * pom)
22523       gradpepcat(k,i) = gradpepcat(k,i)  &
22524               - (( dFdR + gg(k) ) * ertail(k))
22525       gradpepcat(k,j) = gradpepcat(k,j) &
22526               + (( dFdR + gg(k) ) * ertail(k))
22527       gg(k) = 0.0d0
22528        ENDDO
22529 !c! Compute head-head and head-tail energies for each state
22530         isel = iabs(Qi) + 1 ! ion is always charged so  iabs(Qj)
22531         IF (isel.eq.0) THEN
22532 !c! No charges - do nothing
22533          eheadtail = 0.0d0
22534
22535         ELSE IF (isel.eq.1) THEN
22536 !c! Nonpolar-charge interactions
22537         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22538           Qi=Qi*2
22539           Qij=Qij*2
22540          endif
22541         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
22542           Qj=Qj*2
22543           Qij=Qij*2
22544          endif
22545
22546          CALL enq_cat(epol)
22547          eheadtail = epol
22548 !           eheadtail = 0.0d0
22549
22550         ELSE IF (isel.eq.3) THEN
22551 !c! Dipole-charge interactions
22552         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22553           Qi=Qi*2
22554           Qij=Qij*2
22555          endif
22556         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
22557           Qj=Qj*2
22558           Qij=Qij*2
22559          endif
22560 !         write(iout,*) "KURWA0",d1
22561
22562          CALL edq_cat(ecl, elj, epol)
22563         eheadtail = ECL + elj + epol
22564 !           eheadtail = 0.0d0
22565
22566         ELSE IF ((isel.eq.2)) THEN
22567
22568 !c! Same charge-charge interaction ( +/+ or -/- )
22569         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22570           Qi=Qi*2
22571           Qij=Qij*2
22572          endif
22573         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
22574           Qj=Qj*2
22575           Qij=Qij*2
22576          endif
22577
22578          CALL eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
22579          eheadtail = ECL + Egb + Epol + Fisocav + Elj
22580 !           eheadtail = 0.0d0
22581
22582 !          ELSE IF ((isel.eq.2.and.  &
22583 !               iabs(Qi).eq.1).and. &
22584 !               nstate(itypi,itypj).ne.1) THEN
22585 !c! Different charge-charge interaction ( +/- or -/+ )
22586 !          if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22587 !            Qi=Qi*2
22588 !            Qij=Qij*2
22589 !           endif
22590 !          if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
22591 !            Qj=Qj*2
22592 !            Qij=Qij*2
22593 !           endif
22594 !
22595 !           CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
22596        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
22597       evdw = evdw  + Fcav + eheadtail
22598
22599        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
22600       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
22601       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
22602       Equad,evdwij+Fcav+eheadtail,evdw
22603 !       evdw = evdw  + Fcav  + eheadtail
22604
22605 !        iF (nstate(itypi,itypj).eq.1) THEN
22606       CALL sc_grad_cat
22607 !       END IF
22608 !c!-------------------------------------------------------------------
22609 !c! NAPISY KONCOWE
22610        END DO   ! j
22611        END DO     ! i
22612 !c      write (iout,*) "Number of loop steps in EGB:",ind
22613 !c      energy_dec=.false.
22614 !              print *,"EVDW KURW",evdw,nres
22615 !!!        return
22616    17   continue
22617       do i=ibond_start,ibond_end
22618
22619 !        print *,"I am in EVDW",i
22620       itypi=10 ! the peptide group parameters are for glicine
22621
22622 !        if (i.ne.47) cycle
22623       if ((itype(i,1).eq.ntyp1).or.itype(i+1,1).eq.ntyp1) cycle
22624       itypi1=iabs(itype(i+1,1))
22625       xi=(c(1,i)+c(1,i+1))/2.0
22626       yi=(c(2,i)+c(2,i+1))/2.0
22627       zi=(c(3,i)+c(3,i+1))/2.0
22628         call to_box(xi,yi,zi)
22629       dxi=dc_norm(1,i)
22630       dyi=dc_norm(2,i)
22631       dzi=dc_norm(3,i)
22632       dsci_inv=vbld_inv(i+1)/2.0
22633        do j=itmp+1,itmp+nres_molec(5)
22634
22635 ! Calculate SC interaction energy.
22636           itypj=iabs(itype(j,5))
22637           if ((itypj.eq.ntyp1)) cycle
22638            CALL elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
22639
22640           dscj_inv=0.0
22641          xj=c(1,j)
22642          yj=c(2,j)
22643          zj=c(3,j)
22644         call to_box(xj,yj,zj)
22645         dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22646
22647         dxj = 0.0d0! dc_norm( 1, nres+j )
22648         dyj = 0.0d0!dc_norm( 2, nres+j )
22649         dzj = 0.0d0! dc_norm( 3, nres+j )
22650
22651         itypi = 10
22652         itypj = itype(j,5)
22653 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
22654 ! sampling performed with amber package
22655 !          alf1   = 0.0d0
22656 !          alf2   = 0.0d0
22657 !          alf12  = 0.0d0
22658 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
22659         chi1 = chi1cat(itypi,itypj)
22660         chis1 = chis1cat(itypi,itypj)
22661         chip1 = chipp1cat(itypi,itypj)
22662 !          chi1=0.0d0
22663 !          chis1=0.0d0
22664 !          chip1=0.0d0
22665         chi2=0.0
22666         chip2=0.0
22667         chis2=0.0
22668 !          chis2 = chis(itypj,itypi)
22669         chis12 = chis1 * chis2
22670         sig1 = sigmap1cat(itypi,itypj)
22671 !          sig2 = sigmap2(itypi,itypj)
22672 ! alpha factors from Fcav/Gcav
22673         b1cav = alphasurcat(1,itypi,itypj)
22674         b2cav = alphasurcat(2,itypi,itypj)
22675         b3cav = alphasurcat(3,itypi,itypj)
22676         b4cav = alphasurcat(4,itypi,itypj)
22677
22678 ! used to determine whether we want to do quadrupole calculations
22679        eps_in = epsintabcat(itypi,itypj)
22680        if (eps_in.eq.0.0) eps_in=1.0
22681
22682        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
22683 !       Rtail = 0.0d0
22684
22685        DO k = 1, 3
22686       ctail(k,1)=(c(k,i)+c(k,i+1))/2.0
22687       ctail(k,2)=c(k,j)
22688        END DO
22689 !c! tail distances will be themselves usefull elswhere
22690 !c1 (in Gcav, for example)
22691        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
22692        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
22693        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
22694        Rtail = dsqrt( &
22695         (Rtail_distance(1)*Rtail_distance(1)) &
22696       + (Rtail_distance(2)*Rtail_distance(2)) &
22697       + (Rtail_distance(3)*Rtail_distance(3)))
22698 ! tail location and distance calculations
22699 ! dhead1
22700        d1 = dheadcat(1, 1, itypi, itypj)
22701 !       print *,"d1",d1
22702 !       d1=0.0d0
22703 !       d2 = dhead(2, 1, itypi, itypj)
22704        DO k = 1,3
22705 ! location of polar head is computed by taking hydrophobic centre
22706 ! and moving by a d1 * dc_norm vector
22707 ! see unres publications for very informative images
22708       chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
22709       chead(k,2) = c(k, j)
22710 ! distance
22711 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22712 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22713       Rhead_distance(k) = chead(k,2) - chead(k,1)
22714        END DO
22715 ! pitagoras (root of sum of squares)
22716        Rhead = dsqrt( &
22717         (Rhead_distance(1)*Rhead_distance(1)) &
22718       + (Rhead_distance(2)*Rhead_distance(2)) &
22719       + (Rhead_distance(3)*Rhead_distance(3)))
22720 !-------------------------------------------------------------------
22721 ! zero everything that should be zero'ed
22722        evdwij = 0.0d0
22723        ECL = 0.0d0
22724        Elj = 0.0d0
22725        Equad = 0.0d0
22726        Epol = 0.0d0
22727        Fcav=0.0d0
22728        eheadtail = 0.0d0
22729        dGCLdOM1 = 0.0d0
22730        dGCLdOM2 = 0.0d0
22731        dGCLdOM12 = 0.0d0
22732        dPOLdOM1 = 0.0d0
22733        dPOLdOM2 = 0.0d0
22734         Fcav = 0.0d0
22735         dFdR = 0.0d0
22736         dCAVdOM1  = 0.0d0
22737         dCAVdOM2  = 0.0d0
22738         dCAVdOM12 = 0.0d0
22739         dscj_inv = vbld_inv(j+nres)
22740 !          print *,i,j,dscj_inv,dsci_inv
22741 ! rij holds 1/(distance of Calpha atoms)
22742         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
22743         rij  = dsqrt(rrij)
22744         CALL sc_angular
22745 ! this should be in elgrad_init but om's are calculated by sc_angular
22746 ! which in turn is used by older potentials
22747 ! om = omega, sqom = om^2
22748         sqom1  = om1 * om1
22749         sqom2  = om2 * om2
22750         sqom12 = om12 * om12
22751
22752 ! now we calculate EGB - Gey-Berne
22753 ! It will be summed up in evdwij and saved in evdw
22754         sigsq     = 1.0D0  / sigsq
22755         sig       = sig0ij * dsqrt(sigsq)
22756 !          rij_shift = 1.0D0  / rij - sig + sig0ij
22757         rij_shift = Rtail - sig + sig0ij
22758         IF (rij_shift.le.0.0D0) THEN
22759          evdw = 1.0D20
22760          RETURN
22761         END IF
22762         sigder = -sig * sigsq
22763         rij_shift = 1.0D0 / rij_shift
22764         fac       = rij_shift**expon
22765         c1        = fac  * fac * aa_aq_cat(itypi,itypj)
22766 !          print *,"ADAM",aa_aq(itypi,itypj)
22767
22768 !          c1        = 0.0d0
22769         c2        = fac  * bb_aq_cat(itypi,itypj)
22770 !          c2        = 0.0d0
22771         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
22772         eps2der   = eps3rt * evdwij
22773         eps3der   = eps2rt * evdwij
22774 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
22775         evdwij    = eps2rt * eps3rt * evdwij
22776 !#ifdef TSCSC
22777 !          IF (bb_aq(itypi,itypj).gt.0) THEN
22778 !           evdw_p = evdw_p + evdwij
22779 !          ELSE
22780 !           evdw_m = evdw_m + evdwij
22781 !          END IF
22782 !#else
22783         evdw = evdw  &
22784             + evdwij
22785 !#endif
22786         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
22787         fac    = -expon * (c1 + evdwij) * rij_shift
22788         sigder = fac * sigder
22789 ! Calculate distance derivative
22790         gg(1) =  fac
22791         gg(2) =  fac
22792         gg(3) =  fac
22793
22794         fac = chis1 * sqom1 + chis2 * sqom2 &
22795         - 2.0d0 * chis12 * om1 * om2 * om12
22796
22797         pom = 1.0d0 - chis1 * chis2 * sqom12
22798 !          print *,"TUT2",fac,chis1,sqom1,pom
22799         Lambf = (1.0d0 - (fac / pom))
22800         Lambf = dsqrt(Lambf)
22801         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
22802         Chif = Rtail * sparrow
22803         ChiLambf = Chif * Lambf
22804         eagle = dsqrt(ChiLambf)
22805         bat = ChiLambf ** 11.0d0
22806         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
22807         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
22808         botsq = bot * bot
22809         Fcav = top / bot
22810
22811        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
22812        dbot = 12.0d0 * b4cav * bat * Lambf
22813        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
22814
22815         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
22816         dbot = 12.0d0 * b4cav * bat * Chif
22817         eagle = Lambf * pom
22818         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
22819         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
22820         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
22821             * (chis2 * om2 * om12 - om1) / (eagle * pom)
22822
22823         dFdL = ((dtop * bot - top * dbot) / botsq)
22824         dCAVdOM1  = dFdL * ( dFdOM1 )
22825         dCAVdOM2  = dFdL * ( dFdOM2 )
22826         dCAVdOM12 = dFdL * ( dFdOM12 )
22827
22828        DO k= 1, 3
22829       ertail(k) = Rtail_distance(k)/Rtail
22830        END DO
22831        erdxi = scalar( ertail(1), dC_norm(1,i) )
22832        erdxj = scalar( ertail(1), dC_norm(1,j) )
22833        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i)
22834        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j+nres)
22835        DO k = 1, 3
22836       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i))
22837 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
22838 !                  - (( dFdR + gg(k) ) * pom)
22839       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
22840 !        gvdwx(k,j) = gvdwx(k,j)   &
22841 !                  + (( dFdR + gg(k) ) * pom)
22842       gradpepcat(k,i) = gradpepcat(k,i)  &
22843               - (( dFdR + gg(k) ) * ertail(k))/2.0d0
22844       gradpepcat(k,i+1) = gradpepcat(k,i+1)  &
22845               - (( dFdR + gg(k) ) * ertail(k))/2.0d0
22846
22847       gradpepcat(k,j) = gradpepcat(k,j) &
22848               + (( dFdR + gg(k) ) * ertail(k))
22849       gg(k) = 0.0d0
22850        ENDDO
22851 !c! Compute head-head and head-tail energies for each state
22852         isel = 3
22853 !c! Dipole-charge interactions
22854         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22855           Qi=Qi*2
22856           Qij=Qij*2
22857          endif
22858         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
22859           Qj=Qj*2
22860           Qij=Qij*2
22861          endif
22862          CALL edq_cat_pep(ecl, elj, epol)
22863          eheadtail = ECL + elj + epol
22864 !          print *,"i,",i,eheadtail
22865 !           eheadtail = 0.0d0
22866
22867       evdw = evdw  + Fcav + eheadtail
22868
22869        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
22870       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
22871       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
22872       Equad,evdwij+Fcav+eheadtail,evdw
22873 !       evdw = evdw  + Fcav  + eheadtail
22874
22875 !        iF (nstate(itypi,itypj).eq.1) THEN
22876       CALL sc_grad_cat_pep
22877 !       END IF
22878 !c!-------------------------------------------------------------------
22879 !c! NAPISY KONCOWE
22880        END DO   ! j
22881        END DO     ! i
22882 !c      write (iout,*) "Number of loop steps in EGB:",ind
22883 !c      energy_dec=.false.
22884 !              print *,"EVDW KURW",evdw,nres
22885
22886
22887       return
22888       end subroutine ecats_prot_amber
22889
22890 !---------------------------------------------------------------------------
22891 ! old for Ca2+
22892        subroutine ecat_prot(ecation_prot)
22893 !      use calc_data
22894 !      use comm_momo
22895        integer i,j,k,subchap,itmp,inum
22896       real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22897       r7,r4,ecationcation
22898       real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22899       dist_init,dist_temp,ecation_prot,rcal,rocal,   &
22900       Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
22901       catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
22902       wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
22903       costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
22904       Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
22905       rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
22906       opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
22907       opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
22908       Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip,&
22909       ndiv,ndivi
22910       real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22911       gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
22912       dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
22913       tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
22914       v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
22915       dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
22916       dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
22917       dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
22918       dEvan1Cat
22919       real(kind=8),dimension(6) :: vcatprm
22920       ecation_prot=0.0d0
22921 ! first lets calculate interaction with peptide groups
22922       if (nres_molec(5).eq.0) return
22923       itmp=0
22924       do i=1,4
22925       itmp=itmp+nres_molec(i)
22926       enddo
22927 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
22928       do i=ibond_start,ibond_end
22929 !         cycle
22930        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
22931       xi=0.5d0*(c(1,i)+c(1,i+1))
22932       yi=0.5d0*(c(2,i)+c(2,i+1))
22933       zi=0.5d0*(c(3,i)+c(3,i+1))
22934         call to_box(xi,yi,zi)
22935
22936        do j=itmp+1,itmp+nres_molec(5)
22937 !           print *,"WTF",itmp,j,i
22938 ! all parameters were for Ca2+ to approximate single charge divide by two
22939        ndiv=1.0
22940        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
22941        wconst=78*ndiv
22942       wdip =1.092777950857032D2
22943       wdip=wdip/wconst
22944       wmodquad=-2.174122713004870D4
22945       wmodquad=wmodquad/wconst
22946       wquad1 = 3.901232068562804D1
22947       wquad1=wquad1/wconst
22948       wquad2 = 3
22949       wquad2=wquad2/wconst
22950       wvan1 = 0.1
22951       wvan2 = 6
22952 !        itmp=0
22953
22954          xj=c(1,j)
22955          yj=c(2,j)
22956          zj=c(3,j)
22957         call to_box(xj,yj,zj)
22958       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22959 !       enddo
22960 !       enddo
22961        rcpm = sqrt(xj**2+yj**2+zj**2)
22962        drcp_norm(1)=xj/rcpm
22963        drcp_norm(2)=yj/rcpm
22964        drcp_norm(3)=zj/rcpm
22965        dcmag=0.0
22966        do k=1,3
22967        dcmag=dcmag+dc(k,i)**2
22968        enddo
22969        dcmag=dsqrt(dcmag)
22970        do k=1,3
22971        myd_norm(k)=dc(k,i)/dcmag
22972        enddo
22973       costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
22974       drcp_norm(3)*myd_norm(3)
22975       rsecp = rcpm**2
22976       Ir = 1.0d0/rcpm
22977       Irsecp = 1.0d0/rsecp
22978       Irthrp = Irsecp/rcpm
22979       Irfourp = Irthrp/rcpm
22980       Irfiftp = Irfourp/rcpm
22981       Irsistp=Irfiftp/rcpm
22982       Irseven=Irsistp/rcpm
22983       Irtwelv=Irsistp*Irsistp
22984       Irthir=Irtwelv/rcpm
22985       sin2thet = (1-costhet*costhet)
22986       sinthet=sqrt(sin2thet)
22987       E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
22988            *sin2thet
22989       E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
22990            2*wvan2**6*Irsistp)
22991       ecation_prot = ecation_prot+E1+E2
22992 !        print *,"ecatprot",i,j,ecation_prot,rcpm
22993       dE1dr = -2*costhet*wdip*Irthrp-&
22994        (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
22995       dE2dr = 3*wquad1*wquad2*Irfourp-     &
22996         12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
22997       dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
22998       do k=1,3
22999         drdpep(k) = -drcp_norm(k)
23000         dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
23001         dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
23002         dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
23003         dEddci(k) = dEdcos*dcosddci(k)
23004       enddo
23005       do k=1,3
23006       gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
23007       gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
23008       gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
23009       enddo
23010        enddo ! j
23011        enddo ! i
23012 !------------------------------------------sidechains
23013 !        do i=1,nres_molec(1)
23014       do i=ibond_start,ibond_end
23015        if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
23016 !         cycle
23017 !        print *,i,ecation_prot
23018       xi=(c(1,i+nres))
23019       yi=(c(2,i+nres))
23020       zi=(c(3,i+nres))
23021                 call to_box(xi,yi,zi)
23022         do k=1,3
23023           cm1(k)=dc(k,i+nres)
23024         enddo
23025          cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
23026        do j=itmp+1,itmp+nres_molec(5)
23027        ndiv=1.0
23028        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23029
23030          xj=c(1,j)
23031          yj=c(2,j)
23032          zj=c(3,j)
23033         call to_box(xj,yj,zj)
23034       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23035 !       enddo
23036 !       enddo
23037 ! 15- Glu 16-Asp
23038        if((itype(i,1).eq.15.or.itype(i,1).eq.16).or.&
23039        ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.&
23040        (itype(i,1).eq.25))) then
23041           if(itype(i,1).eq.16) then
23042           inum=1
23043           else
23044           inum=2
23045           endif
23046           do k=1,6
23047           vcatprm(k)=catprm(k,inum)
23048           enddo
23049           dASGL=catprm(7,inum)
23050 !             do k=1,3
23051 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23052             vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23053             vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23054             vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23055
23056 !                valpha(k)=c(k,i)
23057 !                vcat(k)=c(k,j)
23058             if (subchap.eq.1) then
23059              vcat(1)=xj_temp
23060              vcat(2)=yj_temp
23061              vcat(3)=zj_temp
23062              else
23063             vcat(1)=xj_safe
23064             vcat(2)=yj_safe
23065             vcat(3)=zj_safe
23066              endif
23067             valpha(1)=xi-c(1,i+nres)+c(1,i)
23068             valpha(2)=yi-c(2,i+nres)+c(2,i)
23069             valpha(3)=zi-c(3,i+nres)+c(3,i)
23070
23071 !              enddo
23072       do k=1,3
23073         dx(k) = vcat(k)-vcm(k)
23074       enddo
23075       do k=1,3
23076         v1(k)=(vcm(k)-valpha(k))
23077         v2(k)=(vcat(k)-valpha(k))
23078       enddo
23079       v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23080       v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23081       v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23082
23083 !  The weights of the energy function calculated from
23084 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
23085         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23086           ndivi=0.5
23087         else
23088           ndivi=1.0
23089         endif
23090        ndiv=1.0
23091        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23092
23093       wh2o=78*ndivi*ndiv
23094       wc = vcatprm(1)
23095       wc=wc/wh2o
23096       wdip =vcatprm(2)
23097       wdip=wdip/wh2o
23098       wquad1 =vcatprm(3)
23099       wquad1=wquad1/wh2o
23100       wquad2 = vcatprm(4)
23101       wquad2=wquad2/wh2o
23102       wquad2p = 1.0d0-wquad2
23103       wvan1 = vcatprm(5)
23104       wvan2 =vcatprm(6)
23105       opt = dx(1)**2+dx(2)**2
23106       rsecp = opt+dx(3)**2
23107       rs = sqrt(rsecp)
23108       rthrp = rsecp*rs
23109       rfourp = rthrp*rs
23110       rsixp = rfourp*rsecp
23111       reight=rsixp*rsecp
23112       Ir = 1.0d0/rs
23113       Irsecp = 1.0d0/rsecp
23114       Irthrp = Irsecp/rs
23115       Irfourp = Irthrp/rs
23116       Irsixp = 1.0d0/rsixp
23117       Ireight=1.0d0/reight
23118       Irtw=Irsixp*Irsixp
23119       Irthir=Irtw/rs
23120       Irfourt=Irthir/rs
23121       opt1 = (4*rs*dx(3)*wdip)
23122       opt2 = 6*rsecp*wquad1*opt
23123       opt3 = wquad1*wquad2p*Irsixp
23124       opt4 = (wvan1*wvan2**12)
23125       opt5 = opt4*12*Irfourt
23126       opt6 = 2*wvan1*wvan2**6
23127       opt7 = 6*opt6*Ireight
23128       opt8 = wdip/v1m
23129       opt10 = wdip/v2m
23130       opt11 = (rsecp*v2m)**2
23131       opt12 = (rsecp*v1m)**2
23132       opt14 = (v1m*v2m*rsecp)**2
23133       opt15 = -wquad1/v2m**2
23134       opt16 = (rthrp*(v1m*v2m)**2)**2
23135       opt17 = (v1m**2*rthrp)**2
23136       opt18 = -wquad1/rthrp
23137       opt19 = (v1m**2*v2m**2)**2
23138       Ec = wc*Ir
23139       do k=1,3
23140         dEcCat(k) = -(dx(k)*wc)*Irthrp
23141         dEcCm(k)=(dx(k)*wc)*Irthrp
23142         dEcCalp(k)=0.0d0
23143       enddo
23144       Edip=opt8*(v1dpv2)/(rsecp*v2m)
23145       do k=1,3
23146         dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
23147                  *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23148         dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
23149                 *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23150         dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
23151                   *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
23152                   *v1dpv2)/opt14
23153       enddo
23154       Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23155       do k=1,3
23156         dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
23157                    (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
23158                    v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23159         dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
23160                   (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
23161                   v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23162         dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23163                   v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
23164                   v1dpv2**2)/opt19
23165       enddo
23166       Equad2=wquad1*wquad2p*Irthrp
23167       do k=1,3
23168         dEquad2Cat(k)=-3*dx(k)*rs*opt3
23169         dEquad2Cm(k)=3*dx(k)*rs*opt3
23170         dEquad2Calp(k)=0.0d0
23171       enddo
23172       Evan1=opt4*Irtw
23173       do k=1,3
23174         dEvan1Cat(k)=-dx(k)*opt5
23175         dEvan1Cm(k)=dx(k)*opt5
23176         dEvan1Calp(k)=0.0d0
23177       enddo
23178       Evan2=-opt6*Irsixp
23179       do k=1,3
23180         dEvan2Cat(k)=dx(k)*opt7
23181         dEvan2Cm(k)=-dx(k)*opt7
23182         dEvan2Calp(k)=0.0d0
23183       enddo
23184       ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
23185 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
23186
23187       do k=1,3
23188         dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
23189                    dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23190 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
23191         dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
23192                   dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23193         dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
23194                   +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23195       enddo
23196           dscmag = 0.0d0
23197           do k=1,3
23198             dscvec(k) = dc(k,i+nres)
23199             dscmag = dscmag+dscvec(k)*dscvec(k)
23200           enddo
23201           dscmag3 = dscmag
23202           dscmag = sqrt(dscmag)
23203           dscmag3 = dscmag3*dscmag
23204           constA = 1.0d0+dASGL/dscmag
23205           constB = 0.0d0
23206           do k=1,3
23207             constB = constB+dscvec(k)*dEtotalCm(k)
23208           enddo
23209           constB = constB*dASGL/dscmag3
23210           do k=1,3
23211             gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23212             gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23213              constA*dEtotalCm(k)-constB*dscvec(k)
23214 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
23215             gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23216             gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23217            enddo
23218       else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
23219          if(itype(i,1).eq.14) then
23220           inum=3
23221           else
23222           inum=4
23223           endif
23224           do k=1,6
23225           vcatprm(k)=catprm(k,inum)
23226           enddo
23227           dASGL=catprm(7,inum)
23228 !             do k=1,3
23229 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23230 !                valpha(k)=c(k,i)
23231 !                vcat(k)=c(k,j)
23232 !              enddo
23233             vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23234             vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23235             vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23236             if (subchap.eq.1) then
23237              vcat(1)=xj_temp
23238              vcat(2)=yj_temp
23239              vcat(3)=zj_temp
23240              else
23241             vcat(1)=xj_safe
23242             vcat(2)=yj_safe
23243             vcat(3)=zj_safe
23244             endif
23245             valpha(1)=xi-c(1,i+nres)+c(1,i)
23246             valpha(2)=yi-c(2,i+nres)+c(2,i)
23247             valpha(3)=zi-c(3,i+nres)+c(3,i)
23248
23249
23250       do k=1,3
23251         dx(k) = vcat(k)-vcm(k)
23252       enddo
23253       do k=1,3
23254         v1(k)=(vcm(k)-valpha(k))
23255         v2(k)=(vcat(k)-valpha(k))
23256       enddo
23257       v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23258       v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23259       v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23260 !  The weights of the energy function calculated from
23261 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
23262        ndiv=1.0
23263        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23264
23265       wh2o=78*ndiv
23266       wdip =vcatprm(2)
23267       wdip=wdip/wh2o
23268       wquad1 =vcatprm(3)
23269       wquad1=wquad1/wh2o
23270       wquad2 = vcatprm(4)
23271       wquad2=wquad2/wh2o
23272       wquad2p = 1-wquad2
23273       wvan1 = vcatprm(5)
23274       wvan2 =vcatprm(6)
23275       opt = dx(1)**2+dx(2)**2
23276       rsecp = opt+dx(3)**2
23277       rs = sqrt(rsecp)
23278       rthrp = rsecp*rs
23279       rfourp = rthrp*rs
23280       rsixp = rfourp*rsecp
23281       reight=rsixp*rsecp
23282       Ir = 1.0d0/rs
23283       Irsecp = 1/rsecp
23284       Irthrp = Irsecp/rs
23285       Irfourp = Irthrp/rs
23286       Irsixp = 1/rsixp
23287       Ireight=1/reight
23288       Irtw=Irsixp*Irsixp
23289       Irthir=Irtw/rs
23290       Irfourt=Irthir/rs
23291       opt1 = (4*rs*dx(3)*wdip)
23292       opt2 = 6*rsecp*wquad1*opt
23293       opt3 = wquad1*wquad2p*Irsixp
23294       opt4 = (wvan1*wvan2**12)
23295       opt5 = opt4*12*Irfourt
23296       opt6 = 2*wvan1*wvan2**6
23297       opt7 = 6*opt6*Ireight
23298       opt8 = wdip/v1m
23299       opt10 = wdip/v2m
23300       opt11 = (rsecp*v2m)**2
23301       opt12 = (rsecp*v1m)**2
23302       opt14 = (v1m*v2m*rsecp)**2
23303       opt15 = -wquad1/v2m**2
23304       opt16 = (rthrp*(v1m*v2m)**2)**2
23305       opt17 = (v1m**2*rthrp)**2
23306       opt18 = -wquad1/rthrp
23307       opt19 = (v1m**2*v2m**2)**2
23308       Edip=opt8*(v1dpv2)/(rsecp*v2m)
23309       do k=1,3
23310         dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
23311                  *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23312        dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
23313                 *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23314         dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
23315                   *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
23316                   *v1dpv2)/opt14
23317       enddo
23318       Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23319       do k=1,3
23320         dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
23321                    (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
23322                    v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23323         dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
23324                   (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
23325                    v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23326         dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23327                   v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
23328                   v1dpv2**2)/opt19
23329       enddo
23330       Equad2=wquad1*wquad2p*Irthrp
23331       do k=1,3
23332         dEquad2Cat(k)=-3*dx(k)*rs*opt3
23333         dEquad2Cm(k)=3*dx(k)*rs*opt3
23334         dEquad2Calp(k)=0.0d0
23335       enddo
23336       Evan1=opt4*Irtw
23337       do k=1,3
23338         dEvan1Cat(k)=-dx(k)*opt5
23339         dEvan1Cm(k)=dx(k)*opt5
23340         dEvan1Calp(k)=0.0d0
23341       enddo
23342       Evan2=-opt6*Irsixp
23343       do k=1,3
23344         dEvan2Cat(k)=dx(k)*opt7
23345         dEvan2Cm(k)=-dx(k)*opt7
23346         dEvan2Calp(k)=0.0d0
23347       enddo
23348        ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
23349       do k=1,3
23350         dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
23351                    dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23352         dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
23353                   dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23354         dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
23355                   +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23356       enddo
23357           dscmag = 0.0d0
23358           do k=1,3
23359             dscvec(k) = c(k,i+nres)-c(k,i)
23360 ! TU SPRAWDZ???
23361 !              dscvec(1) = xj
23362 !              dscvec(2) = yj
23363 !              dscvec(3) = zj
23364
23365             dscmag = dscmag+dscvec(k)*dscvec(k)
23366           enddo
23367           dscmag3 = dscmag
23368           dscmag = sqrt(dscmag)
23369           dscmag3 = dscmag3*dscmag
23370           constA = 1+dASGL/dscmag
23371           constB = 0.0d0
23372           do k=1,3
23373             constB = constB+dscvec(k)*dEtotalCm(k)
23374           enddo
23375           constB = constB*dASGL/dscmag3
23376           do k=1,3
23377             gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23378             gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23379              constA*dEtotalCm(k)-constB*dscvec(k)
23380             gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23381             gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23382            enddo
23383          else
23384           rcal = 0.0d0
23385           do k=1,3
23386 !              r(k) = c(k,j)-c(k,i+nres)
23387             r(1) = xj
23388             r(2) = yj
23389             r(3) = zj
23390             rcal = rcal+r(k)*r(k)
23391           enddo
23392           ract=sqrt(rcal)
23393           rocal=1.5
23394           epscalc=0.2
23395           r0p=0.5*(rocal+sig0(itype(i,1)))
23396           r06 = r0p**6
23397           r012 = r06*r06
23398           Evan1=epscalc*(r012/rcal**6)
23399           Evan2=epscalc*2*(r06/rcal**3)
23400           r4 = rcal**4
23401           r7 = rcal**7
23402           do k=1,3
23403             dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
23404             dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
23405           enddo
23406           do k=1,3
23407             dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
23408           enddo
23409              ecation_prot = ecation_prot+ Evan1+Evan2
23410           do  k=1,3
23411              gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23412              dEtotalCm(k)
23413             gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
23414             gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
23415            enddo
23416        endif ! 13-16 residues
23417        enddo !j
23418        enddo !i
23419        return
23420        end subroutine ecat_prot
23421
23422 !----------------------------------------------------------------------------
23423 !---------------------------------------------------------------------------
23424        subroutine ecat_nucl(ecation_nucl)
23425        integer i,j,k,subchap,itmp,inum,itypi,itypj
23426        real(kind=8) :: xi,yi,zi,xj,yj,zj
23427        real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
23428        dist_init,dist_temp,ecation_nucl,Evan1,Evan2,Ecav,Egb,wdip1,wdip2, &
23429        wvan1,wvan2,wgbsig,wgbeps,wgbchi,wgbchip,wcav1,wcav2,wcav3,wcav4, &
23430        wcavsig,wcavchi,v1m,v1dpdx,wh2o,wc,Edip,rcs2,invrcs6,invrcs8,invrcs12, &
23431        invrcs14,rcb,rcb2,invrcb,invrcb2,invrcb4,invrcb6,cosinus,cos2,dcosdcatconst, &
23432        dcosdcalpconst,dcosdcmconst,rcav,rcav11,rcav12,constcav1,constcav2, &
23433        constgb1,constgb2,constdvan1,constdvan2,sgb,sgb6,sgb7,sgb12,sgb13, &
23434        cavnum,cavdenom,invcavdenom2,dcavnumdcos,dcavnumdr,dcavdenomdcos, &
23435        dcavdenomdr,sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
23436        real(kind=8),dimension(3) ::gg,r,dEtotalCm,dEtotalCalp,dEvan1Cm,&
23437        dEvan2Cm,cm1,cm,vcat,vsug,v1,v2,dx,vcm,dEdipCm,dEdipCalp, &
23438        dEvan1Calp,dEvan2Cat,dEvan2Calp,dEtotalCat,dEdipCat,dEvan1Cat,dcosdcat, &
23439        dcosdcalp,dcosdcm,dEgbdCat,dEgbdCalp,dEgbdCm,dEcavdCat,dEcavdCalp, &
23440        dEcavdCm
23441        real(kind=8),dimension(14) :: vcatnuclprm
23442        ecation_nucl=0.0d0
23443        if (nres_molec(5).eq.0) return
23444        itmp=0
23445        do i=1,4
23446           itmp=itmp+nres_molec(i)
23447        enddo
23448        do i=iatsc_s_nucl,iatsc_e_nucl
23449           if ((itype(i,2).eq.ntyp1_molec(2))) cycle ! leave dummy atoms
23450           xi=(c(1,i+nres))
23451           yi=(c(2,i+nres))
23452           zi=(c(3,i+nres))
23453       call to_box(xi,yi,zi)
23454       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
23455           do k=1,3
23456              cm1(k)=dc(k,i+nres)
23457           enddo
23458           do j=itmp+1,itmp+nres_molec(5)
23459              xj=c(1,j)
23460              yj=c(2,j)
23461              zj=c(3,j)
23462       call to_box(xj,yj,zj)
23463 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
23464 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23465 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23466 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23467 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23468       xj=boxshift(xj-xi,boxxsize)
23469       yj=boxshift(yj-yi,boxysize)
23470       zj=boxshift(zj-zi,boxzsize)
23471
23472              dist_init=xj**2+yj**2+zj**2
23473
23474              itypi=itype(i,2)
23475              itypj=itype(j,5)
23476              do k=1,13
23477                 vcatnuclprm(k)=catnuclprm(k,itypi,itypj)
23478              enddo
23479              do k=1,3
23480                 vcm(k)=c(k,i+nres)
23481                 vsug(k)=c(k,i)
23482                 vcat(k)=c(k,j)
23483              enddo
23484              do k=1,3
23485                 dx(k) = vcat(k)-vcm(k)
23486              enddo
23487              do k=1,3
23488                 v1(k)=dc(k,i+nres)
23489                 v2(k)=(vcat(k)-vsug(k))
23490              enddo
23491              v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23492              v1dpdx = v1(1)*dx(1)+v1(2)*dx(2)+v1(3)*dx(3)
23493 !  The weights of the energy function calculated from
23494 !The quantum mechanical Gaussian simulations of potassium and sodium with deoxynucleosides
23495              wh2o=78
23496              wdip1 = vcatnuclprm(1)
23497              wdip1 = wdip1/wh2o                     !w1
23498              wdip2 = vcatnuclprm(2)
23499              wdip2 = wdip2/wh2o                     !w2
23500              wvan1 = vcatnuclprm(3)
23501              wvan2 = vcatnuclprm(4)                 !pis1
23502              wgbsig = vcatnuclprm(5)                !sigma0
23503              wgbeps = vcatnuclprm(6)                !epsi0
23504              wgbchi = vcatnuclprm(7)                !chi1
23505              wgbchip = vcatnuclprm(8)               !chip1
23506              wcavsig = vcatnuclprm(9)               !sig
23507              wcav1 = vcatnuclprm(10)                !b1
23508              wcav2 = vcatnuclprm(11)                !b2
23509              wcav3 = vcatnuclprm(12)                !b3
23510              wcav4 = vcatnuclprm(13)                !b4
23511              wcavchi = vcatnuclprm(14)              !chis1
23512              rcs2 = v2(1)**2+v2(2)**2+v2(3)**2
23513              invrcs6 = 1/rcs2**3
23514              invrcs8 = invrcs6/rcs2
23515              invrcs12 = invrcs6**2
23516              invrcs14 = invrcs12/rcs2
23517              rcb2 = dx(1)**2+dx(2)**2+dx(3)**2
23518              rcb = sqrt(rcb2)
23519              invrcb = 1/rcb
23520              invrcb2 = invrcb**2
23521              invrcb4 = invrcb2**2
23522              invrcb6 = invrcb4*invrcb2
23523              cosinus = v1dpdx/(v1m*rcb)
23524              cos2 = cosinus**2
23525              dcosdcatconst = invrcb2/v1m
23526              dcosdcalpconst = invrcb/v1m**2
23527              dcosdcmconst = invrcb2/v1m**2
23528              do k=1,3
23529                 dcosdcat(k) = (v1(k)*rcb-dx(k)*v1m*cosinus)*dcosdcatconst
23530                 dcosdcalp(k) = (v1(k)*rcb*cosinus-dx(k)*v1m)*dcosdcalpconst
23531                 dcosdcm(k) = ((dx(k)-v1(k))*v1m*rcb+ &
23532                         cosinus*(dx(k)*v1m**2-v1(k)*rcb2))*dcosdcmconst
23533              enddo
23534              rcav = rcb/wcavsig
23535              rcav11 = rcav**11
23536              rcav12 = rcav11*rcav
23537              constcav1 = 1-wcavchi*cos2
23538              constcav2 = sqrt(constcav1)
23539              constgb1 = 1/sqrt(1-wgbchi*cos2)
23540              constgb2 = wgbeps*(1-wgbchip*cos2)**2
23541              constdvan1 = 12*wvan1*wvan2**12*invrcs14
23542              constdvan2 = 6*wvan1*wvan2**6*invrcs8
23543 !----------------------------------------------------------------------------
23544 !Gay-Berne term
23545 !---------------------------------------------------------------------------
23546              sgb = 1/(1-constgb1+(rcb/wgbsig))
23547              sgb6 = sgb**6
23548              sgb7 = sgb6*sgb
23549              sgb12 = sgb6**2
23550              sgb13 = sgb12*sgb
23551              Egb = constgb2*(sgb12-sgb6)
23552              do k=1,3
23553                 dEgbdCat(k) = -constgb2/wgbsig*(12*sgb13-6*sgb7)*invrcb*dx(k) &
23554                  +(constgb1**3*constgb2*wgbchi*cosinus*(12*sgb13-6*sgb7) &
23555      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcat(k)
23556                 dEgbdCm(k) = constgb2/wgbsig*(12*sgb13-6*sgb7)*invrcb*dx(k) &
23557                  +(constgb1**3*constgb2*wgbchi*cosinus*(12*sgb13-6*sgb7) &
23558      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcm(k)
23559                 dEgbdCalp(k) = (constgb1**3*constgb2*wgbchi*cosinus &
23560                                *(12*sgb13-6*sgb7) &
23561      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcalp(k)
23562              enddo
23563 !----------------------------------------------------------------------------
23564 !cavity term
23565 !---------------------------------------------------------------------------
23566              cavnum = sqrt(rcav*constcav2)+wcav2*rcav*constcav2-wcav3
23567              cavdenom = 1+wcav4*rcav12*constcav1**6
23568              Ecav = wcav1*cavnum/cavdenom
23569              invcavdenom2 = 1/cavdenom**2
23570              dcavnumdcos = -wcavchi*cosinus/constcav2 &
23571                     *(sqrt(rcav/constcav2)/2+wcav2*rcav)
23572              dcavnumdr = (0.5*sqrt(constcav2/rcav)+wcav2*constcav2)/wcavsig
23573              dcavdenomdcos = -12*wcav4*wcavchi*rcav12*constcav1**5*cosinus
23574              dcavdenomdr = 12*wcav4/wcavsig*rcav11*constcav1**6
23575              do k=1,3
23576                 dEcavdCat(k) = ((dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
23577      *dcosdcat(k)+(dcavnumdr*cavdenom-dcavdenomdr*cavnum)/rcb*dx(k))*wcav1*invcavdenom2
23578                 dEcavdCm(k) = ((dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
23579      *dcosdcm(k)-(dcavnumdr*cavdenom-dcavdenomdr*cavnum)/rcb*dx(k))*wcav1*invcavdenom2
23580                 dEcavdCalp(k) = (dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
23581                              *dcosdcalp(k)*wcav1*invcavdenom2
23582              enddo
23583 !----------------------------------------------------------------------------
23584 !van der Waals and dipole-charge interaction energy
23585 !---------------------------------------------------------------------------
23586              Evan1 = wvan1*wvan2**12*invrcs12
23587              do k=1,3
23588                 dEvan1Cat(k) = -v2(k)*constdvan1
23589                 dEvan1Cm(k) = 0.0d0
23590                 dEvan1Calp(k) = v2(k)*constdvan1
23591              enddo
23592              Evan2 = -wvan1*wvan2**6*invrcs6
23593              do k=1,3
23594                 dEvan2Cat(k) = v2(k)*constdvan2
23595                 dEvan2Cm(k) = 0.0d0
23596                 dEvan2Calp(k) = -v2(k)*constdvan2
23597              enddo
23598              Edip = wdip1*cosinus*invrcb2-wdip2*(1-cos2)*invrcb4
23599              do k=1,3
23600                 dEdipCat(k) = (-2*wdip1*cosinus*invrcb4 &
23601                                +4*wdip2*(1-cos2)*invrcb6)*dx(k) &
23602                    +dcosdcat(k)*(wdip1*invrcb2+2*wdip2*cosinus*invrcb4)
23603                 dEdipCm(k) = (2*wdip1*cosinus*invrcb4 &
23604                              -4*wdip2*(1-cos2)*invrcb6)*dx(k) &
23605                    +dcosdcm(k)*(wdip1*invrcb2+2*wdip2*cosinus*invrcb4)
23606                 dEdipCalp(k) = dcosdcalp(k)*(wdip1*invrcb2 &
23607                                   +2*wdip2*cosinus*invrcb4)
23608              enddo
23609              if (energy_dec) write (iout,'(2i5,4(a6,f7.3))') i,j, &
23610          ' E GB ',Egb,' ECav ',Ecav,' Evdw ',Evan1+Evan2,' Edip ',Edip
23611              ecation_nucl=ecation_nucl+Ecav+Egb+Edip+Evan1+Evan2
23612              do k=1,3
23613                 dEtotalCat(k) = dEcavdCat(k)+dEvan1Cat(k)+dEvan2Cat(k) &
23614                                              +dEgbdCat(k)+dEdipCat(k)
23615                 dEtotalCm(k) = dEcavdCm(k)+dEvan1Cm(k)+dEvan2Cm(k) &
23616                                            +dEgbdCm(k)+dEdipCm(k)
23617                 dEtotalCalp(k) = dEcavdCalp(k)+dEgbdCalp(k)+dEvan1Calp(k) &
23618                                              +dEdipCalp(k)+dEvan2Calp(k)
23619              enddo
23620              do k=1,3
23621                 gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23622                 gradnuclcatx(k,i)=gradnuclcatx(k,i)+dEtotalCm(k)
23623                 gradnuclcat(k,i)=gradnuclcat(k,i)+gg(k)
23624                 gradnuclcat(k,j)=gradnuclcat(k,j)+dEtotalCat(k)
23625              enddo
23626           enddo !j
23627        enddo !i
23628        return
23629        end subroutine ecat_nucl
23630
23631 !-----------------------------------------------------------------------------
23632 !-----------------------------------------------------------------------------
23633       subroutine eprot_sc_base(escbase)
23634       use calc_data
23635 !      implicit real*8 (a-h,o-z)
23636 !      include 'DIMENSIONS'
23637 !      include 'COMMON.GEO'
23638 !      include 'COMMON.VAR'
23639 !      include 'COMMON.LOCAL'
23640 !      include 'COMMON.CHAIN'
23641 !      include 'COMMON.DERIV'
23642 !      include 'COMMON.NAMES'
23643 !      include 'COMMON.INTERACT'
23644 !      include 'COMMON.IOUNITS'
23645 !      include 'COMMON.CALC'
23646 !      include 'COMMON.CONTROL'
23647 !      include 'COMMON.SBRIDGE'
23648       logical :: lprn
23649 !el local variables
23650       integer :: iint,itypi,itypi1,itypj,subchap
23651       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23652       real(kind=8) :: evdw,sig0ij
23653       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23654                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23655                 sslipi,sslipj,faclip
23656       integer :: ii
23657       real(kind=8) :: fracinbuf
23658        real (kind=8) :: escbase
23659        real (kind=8),dimension(4):: ener
23660        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23661        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23662       sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
23663       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23664       dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
23665       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23666       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23667       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
23668        real(kind=8),dimension(3,2)::chead,erhead_tail
23669        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23670        integer troll
23671        eps_out=80.0d0
23672        escbase=0.0d0
23673 !       do i=1,nres_molec(1)
23674       do i=ibond_start,ibond_end
23675       if (itype(i,1).eq.ntyp1_molec(1)) cycle
23676       itypi  = itype(i,1)
23677       dxi    = dc_norm(1,nres+i)
23678       dyi    = dc_norm(2,nres+i)
23679       dzi    = dc_norm(3,nres+i)
23680       dsci_inv = vbld_inv(i+nres)
23681       xi=c(1,nres+i)
23682       yi=c(2,nres+i)
23683       zi=c(3,nres+i)
23684       call to_box(xi,yi,zi)
23685       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
23686        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
23687          itypj= itype(j,2)
23688          if (itype(j,2).eq.ntyp1_molec(2))cycle
23689          xj=c(1,j+nres)
23690          yj=c(2,j+nres)
23691          zj=c(3,j+nres)
23692       call to_box(xj,yj,zj)
23693 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
23694 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23695 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23696 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23697 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23698       xj=boxshift(xj-xi,boxxsize)
23699       yj=boxshift(yj-yi,boxysize)
23700       zj=boxshift(zj-zi,boxzsize)
23701
23702         dxj = dc_norm( 1, nres+j )
23703         dyj = dc_norm( 2, nres+j )
23704         dzj = dc_norm( 3, nres+j )
23705 !          print *,i,j,itypi,itypj
23706         d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
23707         d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
23708 !          d1i=0.0d0
23709 !          d1j=0.0d0
23710 !          BetaT = 1.0d0 / (298.0d0 * Rb)
23711 ! Gay-berne var's
23712         sig0ij = sigma_scbase( itypi,itypj )
23713         chi1   = chi_scbase( itypi, itypj,1 )
23714         chi2   = chi_scbase( itypi, itypj,2 )
23715 !          chi1=0.0d0
23716 !          chi2=0.0d0
23717         chi12  = chi1 * chi2
23718         chip1  = chipp_scbase( itypi, itypj,1 )
23719         chip2  = chipp_scbase( itypi, itypj,2 )
23720 !          chip1=0.0d0
23721 !          chip2=0.0d0
23722         chip12 = chip1 * chip2
23723 ! not used by momo potential, but needed by sc_angular which is shared
23724 ! by all energy_potential subroutines
23725         alf1   = 0.0d0
23726         alf2   = 0.0d0
23727         alf12  = 0.0d0
23728         a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
23729 !       a12sq = a12sq * a12sq
23730 ! charge of amino acid itypi is...
23731         chis1 = chis_scbase(itypi,itypj,1)
23732         chis2 = chis_scbase(itypi,itypj,2)
23733         chis12 = chis1 * chis2
23734         sig1 = sigmap1_scbase(itypi,itypj)
23735         sig2 = sigmap2_scbase(itypi,itypj)
23736 !       write (*,*) "sig1 = ", sig1
23737 !       write (*,*) "sig2 = ", sig2
23738 ! alpha factors from Fcav/Gcav
23739         b1 = alphasur_scbase(1,itypi,itypj)
23740 !          b1=0.0d0
23741         b2 = alphasur_scbase(2,itypi,itypj)
23742         b3 = alphasur_scbase(3,itypi,itypj)
23743         b4 = alphasur_scbase(4,itypi,itypj)
23744 ! used to determine whether we want to do quadrupole calculations
23745 ! used by Fgb
23746        eps_in = epsintab_scbase(itypi,itypj)
23747        if (eps_in.eq.0.0) eps_in=1.0
23748        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23749 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
23750 !-------------------------------------------------------------------
23751 ! tail location and distance calculations
23752        DO k = 1,3
23753 ! location of polar head is computed by taking hydrophobic centre
23754 ! and moving by a d1 * dc_norm vector
23755 ! see unres publications for very informative images
23756       chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
23757       chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
23758 ! distance
23759 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23760 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23761       Rhead_distance(k) = chead(k,2) - chead(k,1)
23762        END DO
23763 ! pitagoras (root of sum of squares)
23764        Rhead = dsqrt( &
23765         (Rhead_distance(1)*Rhead_distance(1)) &
23766       + (Rhead_distance(2)*Rhead_distance(2)) &
23767       + (Rhead_distance(3)*Rhead_distance(3)))
23768 !-------------------------------------------------------------------
23769 ! zero everything that should be zero'ed
23770        evdwij = 0.0d0
23771        ECL = 0.0d0
23772        Elj = 0.0d0
23773        Equad = 0.0d0
23774        Epol = 0.0d0
23775        Fcav=0.0d0
23776        eheadtail = 0.0d0
23777        dGCLdOM1 = 0.0d0
23778        dGCLdOM2 = 0.0d0
23779        dGCLdOM12 = 0.0d0
23780        dPOLdOM1 = 0.0d0
23781        dPOLdOM2 = 0.0d0
23782         Fcav = 0.0d0
23783         dFdR = 0.0d0
23784         dCAVdOM1  = 0.0d0
23785         dCAVdOM2  = 0.0d0
23786         dCAVdOM12 = 0.0d0
23787         dscj_inv = vbld_inv(j+nres)
23788 !          print *,i,j,dscj_inv,dsci_inv
23789 ! rij holds 1/(distance of Calpha atoms)
23790         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23791         rij  = dsqrt(rrij)
23792 !----------------------------
23793         CALL sc_angular
23794 ! this should be in elgrad_init but om's are calculated by sc_angular
23795 ! which in turn is used by older potentials
23796 ! om = omega, sqom = om^2
23797         sqom1  = om1 * om1
23798         sqom2  = om2 * om2
23799         sqom12 = om12 * om12
23800
23801 ! now we calculate EGB - Gey-Berne
23802 ! It will be summed up in evdwij and saved in evdw
23803         sigsq     = 1.0D0  / sigsq
23804         sig       = sig0ij * dsqrt(sigsq)
23805 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23806         rij_shift = 1.0/rij - sig + sig0ij
23807         IF (rij_shift.le.0.0D0) THEN
23808          evdw = 1.0D20
23809          RETURN
23810         END IF
23811         sigder = -sig * sigsq
23812         rij_shift = 1.0D0 / rij_shift
23813         fac       = rij_shift**expon
23814         c1        = fac  * fac * aa_scbase(itypi,itypj)
23815 !          c1        = 0.0d0
23816         c2        = fac  * bb_scbase(itypi,itypj)
23817 !          c2        = 0.0d0
23818         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23819         eps2der   = eps3rt * evdwij
23820         eps3der   = eps2rt * evdwij
23821 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23822         evdwij    = eps2rt * eps3rt * evdwij
23823         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23824         fac    = -expon * (c1 + evdwij) * rij_shift
23825         sigder = fac * sigder
23826 !          fac    = rij * fac
23827 ! Calculate distance derivative
23828         gg(1) =  fac
23829         gg(2) =  fac
23830         gg(3) =  fac
23831 !          if (b2.gt.0.0) then
23832         fac = chis1 * sqom1 + chis2 * sqom2 &
23833         - 2.0d0 * chis12 * om1 * om2 * om12
23834 ! we will use pom later in Gcav, so dont mess with it!
23835         pom = 1.0d0 - chis1 * chis2 * sqom12
23836         Lambf = (1.0d0 - (fac / pom))
23837         Lambf = dsqrt(Lambf)
23838         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23839 !       write (*,*) "sparrow = ", sparrow
23840         Chif = 1.0d0/rij * sparrow
23841         ChiLambf = Chif * Lambf
23842         eagle = dsqrt(ChiLambf)
23843         bat = ChiLambf ** 11.0d0
23844         top = b1 * ( eagle + b2 * ChiLambf - b3 )
23845         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23846         botsq = bot * bot
23847         Fcav = top / bot
23848 !          print *,i,j,Fcav
23849         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23850         dbot = 12.0d0 * b4 * bat * Lambf
23851         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23852 !       dFdR = 0.0d0
23853 !      write (*,*) "dFcav/dR = ", dFdR
23854         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23855         dbot = 12.0d0 * b4 * bat * Chif
23856         eagle = Lambf * pom
23857         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23858         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23859         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23860             * (chis2 * om2 * om12 - om1) / (eagle * pom)
23861
23862         dFdL = ((dtop * bot - top * dbot) / botsq)
23863 !       dFdL = 0.0d0
23864         dCAVdOM1  = dFdL * ( dFdOM1 )
23865         dCAVdOM2  = dFdL * ( dFdOM2 )
23866         dCAVdOM12 = dFdL * ( dFdOM12 )
23867
23868         ertail(1) = xj*rij
23869         ertail(2) = yj*rij
23870         ertail(3) = zj*rij
23871 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
23872 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
23873 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
23874 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
23875 !           print *,"EOMY",eom1,eom2,eom12
23876 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
23877 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
23878 ! here dtail=0.0
23879 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
23880 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23881        DO k = 1, 3
23882 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23883 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23884       pom = ertail(k)
23885 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23886       gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
23887               - (( dFdR + gg(k) ) * pom)
23888 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23889 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23890 !     &             - ( dFdR * pom )
23891       pom = ertail(k)
23892 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23893       gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
23894               + (( dFdR + gg(k) ) * pom)
23895 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23896 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23897 !c!     &             + ( dFdR * pom )
23898
23899       gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
23900               - (( dFdR + gg(k) ) * ertail(k))
23901 !c!     &             - ( dFdR * ertail(k))
23902
23903       gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
23904               + (( dFdR + gg(k) ) * ertail(k))
23905 !c!     &             + ( dFdR * ertail(k))
23906
23907       gg(k) = 0.0d0
23908 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23909 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23910       END DO
23911
23912 !          else
23913
23914 !          endif
23915 !Now dipole-dipole
23916        if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
23917        w1 = wdipdip_scbase(1,itypi,itypj)
23918        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
23919        w3 = wdipdip_scbase(2,itypi,itypj)
23920 !c!-------------------------------------------------------------------
23921 !c! ECL
23922        fac = (om12 - 3.0d0 * om1 * om2)
23923        c1 = (w1 / (Rhead**3.0d0)) * fac
23924        c2 = (w2 / Rhead ** 6.0d0)  &
23925        * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23926        c3= (w3/ Rhead ** 6.0d0)  &
23927        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23928        ECL = c1 - c2 + c3
23929 !c!       write (*,*) "w1 = ", w1
23930 !c!       write (*,*) "w2 = ", w2
23931 !c!       write (*,*) "om1 = ", om1
23932 !c!       write (*,*) "om2 = ", om2
23933 !c!       write (*,*) "om12 = ", om12
23934 !c!       write (*,*) "fac = ", fac
23935 !c!       write (*,*) "c1 = ", c1
23936 !c!       write (*,*) "c2 = ", c2
23937 !c!       write (*,*) "Ecl = ", Ecl
23938 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
23939 !c!       write (*,*) "c2_2 = ",
23940 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23941 !c!-------------------------------------------------------------------
23942 !c! dervative of ECL is GCL...
23943 !c! dECL/dr
23944        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
23945        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
23946        * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
23947        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
23948        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23949        dGCLdR = c1 - c2 + c3
23950 !c! dECL/dom1
23951        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
23952        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23953        * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
23954        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
23955        dGCLdOM1 = c1 - c2 + c3
23956 !c! dECL/dom2
23957        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
23958        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23959        * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
23960        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
23961        dGCLdOM2 = c1 - c2 + c3
23962 !c! dECL/dom12
23963        c1 = w1 / (Rhead ** 3.0d0)
23964        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
23965        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
23966        dGCLdOM12 = c1 - c2 + c3
23967        DO k= 1, 3
23968       erhead(k) = Rhead_distance(k)/Rhead
23969        END DO
23970        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23971        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
23972        facd1 = d1i * vbld_inv(i+nres)
23973        facd2 = d1j * vbld_inv(j+nres)
23974        DO k = 1, 3
23975
23976       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23977       gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
23978               - dGCLdR * pom
23979       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
23980       gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
23981               + dGCLdR * pom
23982
23983       gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
23984               - dGCLdR * erhead(k)
23985       gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
23986               + dGCLdR * erhead(k)
23987        END DO
23988        endif
23989 !now charge with dipole eg. ARG-dG
23990        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
23991       alphapol1 = alphapol_scbase(itypi,itypj)
23992        w1        = wqdip_scbase(1,itypi,itypj)
23993        w2        = wqdip_scbase(2,itypi,itypj)
23994 !       w1=0.0d0
23995 !       w2=0.0d0
23996 !       pis       = sig0head_scbase(itypi,itypj)
23997 !       eps_head   = epshead_scbase(itypi,itypj)
23998 !c!-------------------------------------------------------------------
23999 !c! R1 - distance between head of ith side chain and tail of jth sidechain
24000        R1 = 0.0d0
24001        DO k = 1, 3
24002 !c! Calculate head-to-tail distances tail is center of side-chain
24003       R1=R1+(c(k,j+nres)-chead(k,1))**2
24004        END DO
24005 !c! Pitagoras
24006        R1 = dsqrt(R1)
24007
24008 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24009 !c!     &        +dhead(1,1,itypi,itypj))**2))
24010 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24011 !c!     &        +dhead(2,1,itypi,itypj))**2))
24012
24013 !c!-------------------------------------------------------------------
24014 !c! ecl
24015        sparrow  = w1  *  om1
24016        hawk     = w2 *  (1.0d0 - sqom2)
24017        Ecl = sparrow / Rhead**2.0d0 &
24018          - hawk    / Rhead**4.0d0
24019 !c!-------------------------------------------------------------------
24020 !c! derivative of ecl is Gcl
24021 !c! dF/dr part
24022        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
24023             + 4.0d0 * hawk    / Rhead**5.0d0
24024 !c! dF/dom1
24025        dGCLdOM1 = (w1) / (Rhead**2.0d0)
24026 !c! dF/dom2
24027        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
24028 !c--------------------------------------------------------------------
24029 !c Polarization energy
24030 !c Epol
24031        MomoFac1 = (1.0d0 - chi1 * sqom2)
24032        RR1  = R1 * R1 / MomoFac1
24033        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24034        fgb1 = sqrt( RR1 + a12sq * ee1)
24035 !       eps_inout_fac=0.0d0
24036        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
24037 ! derivative of Epol is Gpol...
24038        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
24039             / (fgb1 ** 5.0d0)
24040        dFGBdR1 = ( (R1 / MomoFac1) &
24041            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
24042            / ( 2.0d0 * fgb1 )
24043        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
24044              * (2.0d0 - 0.5d0 * ee1) ) &
24045              / (2.0d0 * fgb1)
24046        dPOLdR1 = dPOLdFGB1 * dFGBdR1
24047 !       dPOLdR1 = 0.0d0
24048        dPOLdOM1 = 0.0d0
24049        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
24050        DO k = 1, 3
24051       erhead(k) = Rhead_distance(k)/Rhead
24052       erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
24053        END DO
24054
24055        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24056        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24057        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
24058 !       bat=0.0d0
24059        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
24060        facd1 = d1i * vbld_inv(i+nres)
24061        facd2 = d1j * vbld_inv(j+nres)
24062 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24063
24064        DO k = 1, 3
24065       hawk = (erhead_tail(k,1) + &
24066       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
24067 !        facd1=0.0d0
24068 !        facd2=0.0d0
24069       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24070       gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
24071                - dGCLdR * pom &
24072                - dPOLdR1 *  (erhead_tail(k,1))
24073 !     &             - dGLJdR * pom
24074
24075       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24076       gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
24077                + dGCLdR * pom  &
24078                + dPOLdR1 * (erhead_tail(k,1))
24079 !     &             + dGLJdR * pom
24080
24081
24082       gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
24083               - dGCLdR * erhead(k) &
24084               - dPOLdR1 * erhead_tail(k,1)
24085 !     &             - dGLJdR * erhead(k)
24086
24087       gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
24088               + dGCLdR * erhead(k)  &
24089               + dPOLdR1 * erhead_tail(k,1)
24090 !     &             + dGLJdR * erhead(k)
24091
24092        END DO
24093        endif
24094 !       print *,i,j,evdwij,epol,Fcav,ECL
24095        escbase=escbase+evdwij+epol+Fcav+ECL
24096        call sc_grad_scbase
24097        enddo
24098       enddo
24099
24100       return
24101       end subroutine eprot_sc_base
24102       SUBROUTINE sc_grad_scbase
24103       use calc_data
24104
24105        real (kind=8) :: dcosom1(3),dcosom2(3)
24106        eom1  =    &
24107             eps2der * eps2rt_om1   &
24108           - 2.0D0 * alf1 * eps3der &
24109           + sigder * sigsq_om1     &
24110           + dCAVdOM1               &
24111           + dGCLdOM1               &
24112           + dPOLdOM1
24113
24114        eom2  =  &
24115             eps2der * eps2rt_om2   &
24116           + 2.0D0 * alf2 * eps3der &
24117           + sigder * sigsq_om2     &
24118           + dCAVdOM2               &
24119           + dGCLdOM2               &
24120           + dPOLdOM2
24121
24122        eom12 =    &
24123             evdwij  * eps1_om12     &
24124           + eps2der * eps2rt_om12   &
24125           - 2.0D0 * alf12 * eps3der &
24126           + sigder *sigsq_om12      &
24127           + dCAVdOM12               &
24128           + dGCLdOM12
24129
24130 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24131 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24132 !               gg(1),gg(2),"rozne"
24133        DO k = 1, 3
24134       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
24135       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24136       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24137       gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
24138              + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24139              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24140       gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
24141              + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24142              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24143       gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
24144       gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
24145        END DO
24146        RETURN
24147       END SUBROUTINE sc_grad_scbase
24148
24149
24150       subroutine epep_sc_base(epepbase)
24151       use calc_data
24152       logical :: lprn
24153 !el local variables
24154       integer :: iint,itypi,itypi1,itypj,subchap
24155       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24156       real(kind=8) :: evdw,sig0ij
24157       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24158                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24159                 sslipi,sslipj,faclip
24160       integer :: ii
24161       real(kind=8) :: fracinbuf
24162        real (kind=8) :: epepbase
24163        real (kind=8),dimension(4):: ener
24164        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24165        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24166       sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
24167       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24168       dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
24169       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24170       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24171       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
24172        real(kind=8),dimension(3,2)::chead,erhead_tail
24173        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24174        integer troll
24175        eps_out=80.0d0
24176        epepbase=0.0d0
24177 !       do i=1,nres_molec(1)-1
24178       do i=ibond_start,ibond_end
24179       if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
24180 !C        itypi  = itype(i,1)
24181       dxi    = dc_norm(1,i)
24182       dyi    = dc_norm(2,i)
24183       dzi    = dc_norm(3,i)
24184 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
24185       dsci_inv = vbld_inv(i+1)/2.0
24186       xi=(c(1,i)+c(1,i+1))/2.0
24187       yi=(c(2,i)+c(2,i+1))/2.0
24188       zi=(c(3,i)+c(3,i+1))/2.0
24189         call to_box(xi,yi,zi)
24190        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
24191          itypj= itype(j,2)
24192          if (itype(j,2).eq.ntyp1_molec(2))cycle
24193          xj=c(1,j+nres)
24194          yj=c(2,j+nres)
24195          zj=c(3,j+nres)
24196                 call to_box(xj,yj,zj)
24197       xj=boxshift(xj-xi,boxxsize)
24198       yj=boxshift(yj-yi,boxysize)
24199       zj=boxshift(zj-zi,boxzsize)
24200         dist_init=xj**2+yj**2+zj**2
24201         dxj = dc_norm( 1, nres+j )
24202         dyj = dc_norm( 2, nres+j )
24203         dzj = dc_norm( 3, nres+j )
24204 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
24205 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
24206
24207 ! Gay-berne var's
24208         sig0ij = sigma_pepbase(itypj )
24209         chi1   = chi_pepbase(itypj,1 )
24210         chi2   = chi_pepbase(itypj,2 )
24211 !          chi1=0.0d0
24212 !          chi2=0.0d0
24213         chi12  = chi1 * chi2
24214         chip1  = chipp_pepbase(itypj,1 )
24215         chip2  = chipp_pepbase(itypj,2 )
24216 !          chip1=0.0d0
24217 !          chip2=0.0d0
24218         chip12 = chip1 * chip2
24219         chis1 = chis_pepbase(itypj,1)
24220         chis2 = chis_pepbase(itypj,2)
24221         chis12 = chis1 * chis2
24222         sig1 = sigmap1_pepbase(itypj)
24223         sig2 = sigmap2_pepbase(itypj)
24224 !       write (*,*) "sig1 = ", sig1
24225 !       write (*,*) "sig2 = ", sig2
24226        DO k = 1,3
24227 ! location of polar head is computed by taking hydrophobic centre
24228 ! and moving by a d1 * dc_norm vector
24229 ! see unres publications for very informative images
24230       chead(k,1) = (c(k,i)+c(k,i+1))/2.0
24231 ! + d1i * dc_norm(k, i+nres)
24232       chead(k,2) = c(k, j+nres)
24233 ! + d1j * dc_norm(k, j+nres)
24234 ! distance
24235 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24236 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24237       Rhead_distance(k) = chead(k,2) - chead(k,1)
24238 !        print *,gvdwc_pepbase(k,i)
24239
24240        END DO
24241        Rhead = dsqrt( &
24242         (Rhead_distance(1)*Rhead_distance(1)) &
24243       + (Rhead_distance(2)*Rhead_distance(2)) &
24244       + (Rhead_distance(3)*Rhead_distance(3)))
24245
24246 ! alpha factors from Fcav/Gcav
24247         b1 = alphasur_pepbase(1,itypj)
24248 !          b1=0.0d0
24249         b2 = alphasur_pepbase(2,itypj)
24250         b3 = alphasur_pepbase(3,itypj)
24251         b4 = alphasur_pepbase(4,itypj)
24252         alf1   = 0.0d0
24253         alf2   = 0.0d0
24254         alf12  = 0.0d0
24255         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24256 !          print *,i,j,rrij
24257         rij  = dsqrt(rrij)
24258 !----------------------------
24259        evdwij = 0.0d0
24260        ECL = 0.0d0
24261        Elj = 0.0d0
24262        Equad = 0.0d0
24263        Epol = 0.0d0
24264        Fcav=0.0d0
24265        eheadtail = 0.0d0
24266        dGCLdOM1 = 0.0d0
24267        dGCLdOM2 = 0.0d0
24268        dGCLdOM12 = 0.0d0
24269        dPOLdOM1 = 0.0d0
24270        dPOLdOM2 = 0.0d0
24271         Fcav = 0.0d0
24272         dFdR = 0.0d0
24273         dCAVdOM1  = 0.0d0
24274         dCAVdOM2  = 0.0d0
24275         dCAVdOM12 = 0.0d0
24276         dscj_inv = vbld_inv(j+nres)
24277         CALL sc_angular
24278 ! this should be in elgrad_init but om's are calculated by sc_angular
24279 ! which in turn is used by older potentials
24280 ! om = omega, sqom = om^2
24281         sqom1  = om1 * om1
24282         sqom2  = om2 * om2
24283         sqom12 = om12 * om12
24284
24285 ! now we calculate EGB - Gey-Berne
24286 ! It will be summed up in evdwij and saved in evdw
24287         sigsq     = 1.0D0  / sigsq
24288         sig       = sig0ij * dsqrt(sigsq)
24289         rij_shift = 1.0/rij - sig + sig0ij
24290         IF (rij_shift.le.0.0D0) THEN
24291          evdw = 1.0D20
24292          RETURN
24293         END IF
24294         sigder = -sig * sigsq
24295         rij_shift = 1.0D0 / rij_shift
24296         fac       = rij_shift**expon
24297         c1        = fac  * fac * aa_pepbase(itypj)
24298 !          c1        = 0.0d0
24299         c2        = fac  * bb_pepbase(itypj)
24300 !          c2        = 0.0d0
24301         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24302         eps2der   = eps3rt * evdwij
24303         eps3der   = eps2rt * evdwij
24304 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24305         evdwij    = eps2rt * eps3rt * evdwij
24306         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24307         fac    = -expon * (c1 + evdwij) * rij_shift
24308         sigder = fac * sigder
24309 !          fac    = rij * fac
24310 ! Calculate distance derivative
24311         gg(1) =  fac
24312         gg(2) =  fac
24313         gg(3) =  fac
24314         fac = chis1 * sqom1 + chis2 * sqom2 &
24315         - 2.0d0 * chis12 * om1 * om2 * om12
24316 ! we will use pom later in Gcav, so dont mess with it!
24317         pom = 1.0d0 - chis1 * chis2 * sqom12
24318         Lambf = (1.0d0 - (fac / pom))
24319         Lambf = dsqrt(Lambf)
24320         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24321 !       write (*,*) "sparrow = ", sparrow
24322         Chif = 1.0d0/rij * sparrow
24323         ChiLambf = Chif * Lambf
24324         eagle = dsqrt(ChiLambf)
24325         bat = ChiLambf ** 11.0d0
24326         top = b1 * ( eagle + b2 * ChiLambf - b3 )
24327         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24328         botsq = bot * bot
24329         Fcav = top / bot
24330 !          print *,i,j,Fcav
24331         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24332         dbot = 12.0d0 * b4 * bat * Lambf
24333         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24334 !       dFdR = 0.0d0
24335 !      write (*,*) "dFcav/dR = ", dFdR
24336         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24337         dbot = 12.0d0 * b4 * bat * Chif
24338         eagle = Lambf * pom
24339         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24340         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24341         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24342             * (chis2 * om2 * om12 - om1) / (eagle * pom)
24343
24344         dFdL = ((dtop * bot - top * dbot) / botsq)
24345 !       dFdL = 0.0d0
24346         dCAVdOM1  = dFdL * ( dFdOM1 )
24347         dCAVdOM2  = dFdL * ( dFdOM2 )
24348         dCAVdOM12 = dFdL * ( dFdOM12 )
24349
24350         ertail(1) = xj*rij
24351         ertail(2) = yj*rij
24352         ertail(3) = zj*rij
24353        DO k = 1, 3
24354 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24355 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24356       pom = ertail(k)
24357 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24358       gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24359               - (( dFdR + gg(k) ) * pom)/2.0
24360 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
24361 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24362 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24363 !     &             - ( dFdR * pom )
24364       pom = ertail(k)
24365 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24366       gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24367               + (( dFdR + gg(k) ) * pom)
24368 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24369 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24370 !c!     &             + ( dFdR * pom )
24371
24372       gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24373               - (( dFdR + gg(k) ) * ertail(k))/2.0
24374 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
24375
24376 !c!     &             - ( dFdR * ertail(k))
24377
24378       gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24379               + (( dFdR + gg(k) ) * ertail(k))
24380 !c!     &             + ( dFdR * ertail(k))
24381
24382       gg(k) = 0.0d0
24383 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24384 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24385       END DO
24386
24387
24388        w1 = wdipdip_pepbase(1,itypj)
24389        w2 = -wdipdip_pepbase(3,itypj)/2.0
24390        w3 = wdipdip_pepbase(2,itypj)
24391 !       w1=0.0d0
24392 !       w2=0.0d0
24393 !c!-------------------------------------------------------------------
24394 !c! ECL
24395 !       w3=0.0d0
24396        fac = (om12 - 3.0d0 * om1 * om2)
24397        c1 = (w1 / (Rhead**3.0d0)) * fac
24398        c2 = (w2 / Rhead ** 6.0d0)  &
24399        * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24400        c3= (w3/ Rhead ** 6.0d0)  &
24401        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24402
24403        ECL = c1 - c2 + c3
24404
24405        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
24406        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
24407        * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
24408        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
24409        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24410
24411        dGCLdR = c1 - c2 + c3
24412 !c! dECL/dom1
24413        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
24414        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24415        * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
24416        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
24417        dGCLdOM1 = c1 - c2 + c3
24418 !c! dECL/dom2
24419        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
24420        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24421        * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
24422        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
24423
24424        dGCLdOM2 = c1 - c2 + c3
24425 !c! dECL/dom12
24426        c1 = w1 / (Rhead ** 3.0d0)
24427        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
24428        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
24429        dGCLdOM12 = c1 - c2 + c3
24430        DO k= 1, 3
24431       erhead(k) = Rhead_distance(k)/Rhead
24432        END DO
24433        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24434        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24435 !       facd1 = d1 * vbld_inv(i+nres)
24436 !       facd2 = d2 * vbld_inv(j+nres)
24437        DO k = 1, 3
24438
24439 !        pom = erhead(k)
24440 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24441 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
24442 !                  - dGCLdR * pom
24443       pom = erhead(k)
24444 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24445       gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24446               + dGCLdR * pom
24447
24448       gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24449               - dGCLdR * erhead(k)/2.0d0
24450 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24451       gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24452               - dGCLdR * erhead(k)/2.0d0
24453 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24454       gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24455               + dGCLdR * erhead(k)
24456        END DO
24457 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
24458        epepbase=epepbase+evdwij+Fcav+ECL
24459        call sc_grad_pepbase
24460        enddo
24461        enddo
24462       END SUBROUTINE epep_sc_base
24463       SUBROUTINE sc_grad_pepbase
24464       use calc_data
24465
24466        real (kind=8) :: dcosom1(3),dcosom2(3)
24467        eom1  =    &
24468             eps2der * eps2rt_om1   &
24469           - 2.0D0 * alf1 * eps3der &
24470           + sigder * sigsq_om1     &
24471           + dCAVdOM1               &
24472           + dGCLdOM1               &
24473           + dPOLdOM1
24474
24475        eom2  =  &
24476             eps2der * eps2rt_om2   &
24477           + 2.0D0 * alf2 * eps3der &
24478           + sigder * sigsq_om2     &
24479           + dCAVdOM2               &
24480           + dGCLdOM2               &
24481           + dPOLdOM2
24482
24483        eom12 =    &
24484             evdwij  * eps1_om12     &
24485           + eps2der * eps2rt_om12   &
24486           - 2.0D0 * alf12 * eps3der &
24487           + sigder *sigsq_om12      &
24488           + dCAVdOM12               &
24489           + dGCLdOM12
24490 !        om12=0.0
24491 !        eom12=0.0
24492 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24493 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
24494 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24495 !                 *dsci_inv*2.0
24496 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24497 !               gg(1),gg(2),"rozne"
24498        DO k = 1, 3
24499       dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
24500       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24501       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24502       gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
24503              + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24504              *dsci_inv*2.0 &
24505              - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24506       gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
24507              - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
24508              *dsci_inv*2.0 &
24509              + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24510 !         print *,eom12,eom2,om12,om2
24511 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
24512 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
24513       gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
24514              + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
24515              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24516       gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
24517        END DO
24518        RETURN
24519       END SUBROUTINE sc_grad_pepbase
24520       subroutine eprot_sc_phosphate(escpho)
24521       use calc_data
24522 !      implicit real*8 (a-h,o-z)
24523 !      include 'DIMENSIONS'
24524 !      include 'COMMON.GEO'
24525 !      include 'COMMON.VAR'
24526 !      include 'COMMON.LOCAL'
24527 !      include 'COMMON.CHAIN'
24528 !      include 'COMMON.DERIV'
24529 !      include 'COMMON.NAMES'
24530 !      include 'COMMON.INTERACT'
24531 !      include 'COMMON.IOUNITS'
24532 !      include 'COMMON.CALC'
24533 !      include 'COMMON.CONTROL'
24534 !      include 'COMMON.SBRIDGE'
24535       logical :: lprn
24536 !el local variables
24537       integer :: iint,itypi,itypi1,itypj,subchap
24538       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24539       real(kind=8) :: evdw,sig0ij,aa,bb
24540       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24541                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
24542                 sslipi,sslipj,faclip,alpha_sco
24543       integer :: ii
24544       real(kind=8) :: fracinbuf
24545        real (kind=8) :: escpho
24546        real (kind=8),dimension(4):: ener
24547        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24548        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24549       sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
24550       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24551       dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
24552       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24553       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24554       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
24555        real(kind=8),dimension(3,2)::chead,erhead_tail
24556        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24557        integer troll
24558        eps_out=80.0d0
24559        escpho=0.0d0
24560 !       do i=1,nres_molec(1)
24561       do i=ibond_start,ibond_end
24562       if (itype(i,1).eq.ntyp1_molec(1)) cycle
24563       itypi  = itype(i,1)
24564       dxi    = dc_norm(1,nres+i)
24565       dyi    = dc_norm(2,nres+i)
24566       dzi    = dc_norm(3,nres+i)
24567       dsci_inv = vbld_inv(i+nres)
24568       xi=c(1,nres+i)
24569       yi=c(2,nres+i)
24570       zi=c(3,nres+i)
24571        call to_box(xi,yi,zi)
24572       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
24573        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
24574          itypj= itype(j,2)
24575          if ((itype(j,2).eq.ntyp1_molec(2)).or.&
24576           (itype(j+1,2).eq.ntyp1_molec(2))) cycle
24577          xj=(c(1,j)+c(1,j+1))/2.0
24578          yj=(c(2,j)+c(2,j+1))/2.0
24579          zj=(c(3,j)+c(3,j+1))/2.0
24580      call to_box(xj,yj,zj)
24581 !     call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
24582 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
24583 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
24584 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
24585 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
24586       xj=boxshift(xj-xi,boxxsize)
24587       yj=boxshift(yj-yi,boxysize)
24588       zj=boxshift(zj-zi,boxzsize)
24589           dxj = dc_norm( 1,j )
24590         dyj = dc_norm( 2,j )
24591         dzj = dc_norm( 3,j )
24592         dscj_inv = vbld_inv(j+1)
24593
24594 ! Gay-berne var's
24595         sig0ij = sigma_scpho(itypi )
24596         chi1   = chi_scpho(itypi,1 )
24597         chi2   = chi_scpho(itypi,2 )
24598 !          chi1=0.0d0
24599 !          chi2=0.0d0
24600         chi12  = chi1 * chi2
24601         chip1  = chipp_scpho(itypi,1 )
24602         chip2  = chipp_scpho(itypi,2 )
24603 !          chip1=0.0d0
24604 !          chip2=0.0d0
24605         chip12 = chip1 * chip2
24606         chis1 = chis_scpho(itypi,1)
24607         chis2 = chis_scpho(itypi,2)
24608         chis12 = chis1 * chis2
24609         sig1 = sigmap1_scpho(itypi)
24610         sig2 = sigmap2_scpho(itypi)
24611 !       write (*,*) "sig1 = ", sig1
24612 !       write (*,*) "sig1 = ", sig1
24613 !       write (*,*) "sig2 = ", sig2
24614 ! alpha factors from Fcav/Gcav
24615         alf1   = 0.0d0
24616         alf2   = 0.0d0
24617         alf12  = 0.0d0
24618         a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
24619
24620         b1 = alphasur_scpho(1,itypi)
24621 !          b1=0.0d0
24622         b2 = alphasur_scpho(2,itypi)
24623         b3 = alphasur_scpho(3,itypi)
24624         b4 = alphasur_scpho(4,itypi)
24625 ! used to determine whether we want to do quadrupole calculations
24626 ! used by Fgb
24627        eps_in = epsintab_scpho(itypi)
24628        if (eps_in.eq.0.0) eps_in=1.0
24629        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
24630 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
24631 !-------------------------------------------------------------------
24632 ! tail location and distance calculations
24633         d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
24634         d1j = 0.0
24635        DO k = 1,3
24636 ! location of polar head is computed by taking hydrophobic centre
24637 ! and moving by a d1 * dc_norm vector
24638 ! see unres publications for very informative images
24639       chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
24640       chead(k,2) = (c(k, j) + c(k, j+1))/2.0
24641 ! distance
24642 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24643 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24644       Rhead_distance(k) = chead(k,2) - chead(k,1)
24645        END DO
24646 ! pitagoras (root of sum of squares)
24647        Rhead = dsqrt( &
24648         (Rhead_distance(1)*Rhead_distance(1)) &
24649       + (Rhead_distance(2)*Rhead_distance(2)) &
24650       + (Rhead_distance(3)*Rhead_distance(3)))
24651        Rhead_sq=Rhead**2.0
24652 !-------------------------------------------------------------------
24653 ! zero everything that should be zero'ed
24654        evdwij = 0.0d0
24655        ECL = 0.0d0
24656        Elj = 0.0d0
24657        Equad = 0.0d0
24658        Epol = 0.0d0
24659        Fcav=0.0d0
24660        eheadtail = 0.0d0
24661        dGCLdR=0.0d0
24662        dGCLdOM1 = 0.0d0
24663        dGCLdOM2 = 0.0d0
24664        dGCLdOM12 = 0.0d0
24665        dPOLdOM1 = 0.0d0
24666        dPOLdOM2 = 0.0d0
24667         Fcav = 0.0d0
24668         dFdR = 0.0d0
24669         dCAVdOM1  = 0.0d0
24670         dCAVdOM2  = 0.0d0
24671         dCAVdOM12 = 0.0d0
24672         dscj_inv = vbld_inv(j+1)/2.0
24673 !dhead_scbasej(itypi,itypj)
24674 !          print *,i,j,dscj_inv,dsci_inv
24675 ! rij holds 1/(distance of Calpha atoms)
24676         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24677         rij  = dsqrt(rrij)
24678 !----------------------------
24679         CALL sc_angular
24680 ! this should be in elgrad_init but om's are calculated by sc_angular
24681 ! which in turn is used by older potentials
24682 ! om = omega, sqom = om^2
24683         sqom1  = om1 * om1
24684         sqom2  = om2 * om2
24685         sqom12 = om12 * om12
24686
24687 ! now we calculate EGB - Gey-Berne
24688 ! It will be summed up in evdwij and saved in evdw
24689         sigsq     = 1.0D0  / sigsq
24690         sig       = sig0ij * dsqrt(sigsq)
24691 !          rij_shift = 1.0D0  / rij - sig + sig0ij
24692         rij_shift = 1.0/rij - sig + sig0ij
24693         IF (rij_shift.le.0.0D0) THEN
24694          evdw = 1.0D20
24695          RETURN
24696         END IF
24697         sigder = -sig * sigsq
24698         rij_shift = 1.0D0 / rij_shift
24699         fac       = rij_shift**expon
24700         c1        = fac  * fac * aa_scpho(itypi)
24701 !          c1        = 0.0d0
24702         c2        = fac  * bb_scpho(itypi)
24703 !          c2        = 0.0d0
24704         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24705         eps2der   = eps3rt * evdwij
24706         eps3der   = eps2rt * evdwij
24707 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24708         evdwij    = eps2rt * eps3rt * evdwij
24709         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24710         fac    = -expon * (c1 + evdwij) * rij_shift
24711         sigder = fac * sigder
24712 !          fac    = rij * fac
24713 ! Calculate distance derivative
24714         gg(1) =  fac
24715         gg(2) =  fac
24716         gg(3) =  fac
24717         fac = chis1 * sqom1 + chis2 * sqom2 &
24718         - 2.0d0 * chis12 * om1 * om2 * om12
24719 ! we will use pom later in Gcav, so dont mess with it!
24720         pom = 1.0d0 - chis1 * chis2 * sqom12
24721         Lambf = (1.0d0 - (fac / pom))
24722         Lambf = dsqrt(Lambf)
24723         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24724 !       write (*,*) "sparrow = ", sparrow
24725         Chif = 1.0d0/rij * sparrow
24726         ChiLambf = Chif * Lambf
24727         eagle = dsqrt(ChiLambf)
24728         bat = ChiLambf ** 11.0d0
24729         top = b1 * ( eagle + b2 * ChiLambf - b3 )
24730         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24731         botsq = bot * bot
24732         Fcav = top / bot
24733         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24734         dbot = 12.0d0 * b4 * bat * Lambf
24735         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24736 !       dFdR = 0.0d0
24737 !      write (*,*) "dFcav/dR = ", dFdR
24738         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24739         dbot = 12.0d0 * b4 * bat * Chif
24740         eagle = Lambf * pom
24741         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24742         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24743         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24744             * (chis2 * om2 * om12 - om1) / (eagle * pom)
24745
24746         dFdL = ((dtop * bot - top * dbot) / botsq)
24747 !       dFdL = 0.0d0
24748         dCAVdOM1  = dFdL * ( dFdOM1 )
24749         dCAVdOM2  = dFdL * ( dFdOM2 )
24750         dCAVdOM12 = dFdL * ( dFdOM12 )
24751
24752         ertail(1) = xj*rij
24753         ertail(2) = yj*rij
24754         ertail(3) = zj*rij
24755        DO k = 1, 3
24756 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24757 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24758 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
24759
24760       pom = ertail(k)
24761 !        print *,pom,gg(k),dFdR
24762 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24763       gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
24764               - (( dFdR + gg(k) ) * pom)
24765 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24766 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24767 !     &             - ( dFdR * pom )
24768 !        pom = ertail(k)
24769 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24770 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
24771 !                  + (( dFdR + gg(k) ) * pom)
24772 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24773 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24774 !c!     &             + ( dFdR * pom )
24775
24776       gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
24777               - (( dFdR + gg(k) ) * ertail(k))
24778 !c!     &             - ( dFdR * ertail(k))
24779
24780       gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
24781               + (( dFdR + gg(k) ) * ertail(k))/2.0
24782
24783       gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
24784               + (( dFdR + gg(k) ) * ertail(k))/2.0
24785
24786 !c!     &             + ( dFdR * ertail(k))
24787
24788       gg(k) = 0.0d0
24789       ENDDO
24790 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24791 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24792 !      alphapol1 = alphapol_scpho(itypi)
24793        if (wqq_scpho(itypi).ne.0.0) then
24794        Qij=wqq_scpho(itypi)/eps_in
24795        alpha_sco=1.d0/alphi_scpho(itypi)
24796 !       Qij=0.0
24797        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
24798 !c! derivative of Ecl is Gcl...
24799        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
24800             (Rhead*alpha_sco+1) ) / Rhead_sq
24801        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
24802        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
24803        w1        = wqdip_scpho(1,itypi)
24804        w2        = wqdip_scpho(2,itypi)
24805 !       w1=0.0d0
24806 !       w2=0.0d0
24807 !       pis       = sig0head_scbase(itypi,itypj)
24808 !       eps_head   = epshead_scbase(itypi,itypj)
24809 !c!-------------------------------------------------------------------
24810
24811 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24812 !c!     &        +dhead(1,1,itypi,itypj))**2))
24813 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24814 !c!     &        +dhead(2,1,itypi,itypj))**2))
24815
24816 !c!-------------------------------------------------------------------
24817 !c! ecl
24818        sparrow  = w1  *  om1
24819        hawk     = w2 *  (1.0d0 - sqom2)
24820        Ecl = sparrow / Rhead**2.0d0 &
24821          - hawk    / Rhead**4.0d0
24822 !c!-------------------------------------------------------------------
24823        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
24824          1.0/rij,sparrow
24825
24826 !c! derivative of ecl is Gcl
24827 !c! dF/dr part
24828        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
24829             + 4.0d0 * hawk    / Rhead**5.0d0
24830 !c! dF/dom1
24831        dGCLdOM1 = (w1) / (Rhead**2.0d0)
24832 !c! dF/dom2
24833        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
24834        endif
24835
24836 !c--------------------------------------------------------------------
24837 !c Polarization energy
24838 !c Epol
24839        R1 = 0.0d0
24840        DO k = 1, 3
24841 !c! Calculate head-to-tail distances tail is center of side-chain
24842       R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
24843        END DO
24844 !c! Pitagoras
24845        R1 = dsqrt(R1)
24846
24847       alphapol1 = alphapol_scpho(itypi)
24848 !      alphapol1=0.0
24849        MomoFac1 = (1.0d0 - chi2 * sqom1)
24850        RR1  = R1 * R1 / MomoFac1
24851        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24852 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
24853        fgb1 = sqrt( RR1 + a12sq * ee1)
24854 !       eps_inout_fac=0.0d0
24855        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
24856 ! derivative of Epol is Gpol...
24857        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
24858             / (fgb1 ** 5.0d0)
24859        dFGBdR1 = ( (R1 / MomoFac1) &
24860            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
24861            / ( 2.0d0 * fgb1 )
24862        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
24863              * (2.0d0 - 0.5d0 * ee1) ) &
24864              / (2.0d0 * fgb1)
24865        dPOLdR1 = dPOLdFGB1 * dFGBdR1
24866 !       dPOLdR1 = 0.0d0
24867 !       dPOLdOM1 = 0.0d0
24868        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
24869              * (2.0d0 - 0.5d0 * ee1) ) &
24870              / (2.0d0 * fgb1)
24871
24872        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
24873        dPOLdOM2 = 0.0
24874        DO k = 1, 3
24875       erhead(k) = Rhead_distance(k)/Rhead
24876       erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
24877        END DO
24878
24879        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24880        erdxj = scalar( erhead(1), dC_norm(1,j) )
24881        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
24882 !       bat=0.0d0
24883        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
24884        facd1 = d1i * vbld_inv(i+nres)
24885        facd2 = d1j * vbld_inv(j)
24886 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24887
24888        DO k = 1, 3
24889       hawk = (erhead_tail(k,1) + &
24890       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
24891 !        facd1=0.0d0
24892 !        facd2=0.0d0
24893 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
24894 !                pom,(erhead_tail(k,1))
24895
24896 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
24897       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24898       gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
24899                - dGCLdR * pom &
24900                - dPOLdR1 *  (erhead_tail(k,1))
24901 !     &             - dGLJdR * pom
24902
24903       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
24904 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
24905 !                   + dGCLdR * pom  &
24906 !                   + dPOLdR1 * (erhead_tail(k,1))
24907 !     &             + dGLJdR * pom
24908
24909
24910       gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
24911               - dGCLdR * erhead(k) &
24912               - dPOLdR1 * erhead_tail(k,1)
24913 !     &             - dGLJdR * erhead(k)
24914
24915       gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
24916               + (dGCLdR * erhead(k)  &
24917               + dPOLdR1 * erhead_tail(k,1))/2.0
24918       gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
24919               + (dGCLdR * erhead(k)  &
24920               + dPOLdR1 * erhead_tail(k,1))/2.0
24921
24922 !     &             + dGLJdR * erhead(k)
24923 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
24924
24925        END DO
24926 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
24927        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
24928       "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
24929        escpho=escpho+evdwij+epol+Fcav+ECL
24930        call sc_grad_scpho
24931        enddo
24932
24933       enddo
24934
24935       return
24936       end subroutine eprot_sc_phosphate
24937       SUBROUTINE sc_grad_scpho
24938       use calc_data
24939
24940        real (kind=8) :: dcosom1(3),dcosom2(3)
24941        eom1  =    &
24942             eps2der * eps2rt_om1   &
24943           - 2.0D0 * alf1 * eps3der &
24944           + sigder * sigsq_om1     &
24945           + dCAVdOM1               &
24946           + dGCLdOM1               &
24947           + dPOLdOM1
24948
24949        eom2  =  &
24950             eps2der * eps2rt_om2   &
24951           + 2.0D0 * alf2 * eps3der &
24952           + sigder * sigsq_om2     &
24953           + dCAVdOM2               &
24954           + dGCLdOM2               &
24955           + dPOLdOM2
24956
24957        eom12 =    &
24958             evdwij  * eps1_om12     &
24959           + eps2der * eps2rt_om12   &
24960           - 2.0D0 * alf12 * eps3der &
24961           + sigder *sigsq_om12      &
24962           + dCAVdOM12               &
24963           + dGCLdOM12
24964 !        om12=0.0
24965 !        eom12=0.0
24966 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24967 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
24968 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24969 !                 *dsci_inv*2.0
24970 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24971 !               gg(1),gg(2),"rozne"
24972        DO k = 1, 3
24973       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
24974       dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
24975       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24976       gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
24977              + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
24978              *dscj_inv*2.0 &
24979              - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24980       gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
24981              - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
24982              *dscj_inv*2.0 &
24983              + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24984       gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
24985              + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
24986              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24987
24988 !         print *,eom12,eom2,om12,om2
24989 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
24990 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
24991 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
24992 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
24993 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24994       gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
24995        END DO
24996        RETURN
24997       END SUBROUTINE sc_grad_scpho
24998       subroutine eprot_pep_phosphate(epeppho)
24999       use calc_data
25000 !      implicit real*8 (a-h,o-z)
25001 !      include 'DIMENSIONS'
25002 !      include 'COMMON.GEO'
25003 !      include 'COMMON.VAR'
25004 !      include 'COMMON.LOCAL'
25005 !      include 'COMMON.CHAIN'
25006 !      include 'COMMON.DERIV'
25007 !      include 'COMMON.NAMES'
25008 !      include 'COMMON.INTERACT'
25009 !      include 'COMMON.IOUNITS'
25010 !      include 'COMMON.CALC'
25011 !      include 'COMMON.CONTROL'
25012 !      include 'COMMON.SBRIDGE'
25013       logical :: lprn
25014 !el local variables
25015       integer :: iint,itypi,itypi1,itypj,subchap
25016       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
25017       real(kind=8) :: evdw,sig0ij
25018       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25019                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
25020                 sslipi,sslipj,faclip
25021       integer :: ii
25022       real(kind=8) :: fracinbuf
25023        real (kind=8) :: epeppho
25024        real (kind=8),dimension(4):: ener
25025        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
25026        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
25027       sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
25028       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
25029       dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
25030       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
25031       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
25032       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
25033        real(kind=8),dimension(3,2)::chead,erhead_tail
25034        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
25035        integer troll
25036        real (kind=8) :: dcosom1(3),dcosom2(3)
25037        epeppho=0.0d0
25038 !       do i=1,nres_molec(1)
25039       do i=ibond_start,ibond_end
25040       if (itype(i,1).eq.ntyp1_molec(1)) cycle
25041       itypi  = itype(i,1)
25042       dsci_inv = vbld_inv(i+1)/2.0
25043       dxi    = dc_norm(1,i)
25044       dyi    = dc_norm(2,i)
25045       dzi    = dc_norm(3,i)
25046       xi=(c(1,i)+c(1,i+1))/2.0
25047       yi=(c(2,i)+c(2,i+1))/2.0
25048       zi=(c(3,i)+c(3,i+1))/2.0
25049                call to_box(xi,yi,zi)
25050
25051         do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
25052          itypj= itype(j,2)
25053          if ((itype(j,2).eq.ntyp1_molec(2)).or.&
25054           (itype(j+1,2).eq.ntyp1_molec(2))) cycle
25055          xj=(c(1,j)+c(1,j+1))/2.0
25056          yj=(c(2,j)+c(2,j+1))/2.0
25057          zj=(c(3,j)+c(3,j+1))/2.0
25058                 call to_box(xj,yj,zj)
25059       xj=boxshift(xj-xi,boxxsize)
25060       yj=boxshift(yj-yi,boxysize)
25061       zj=boxshift(zj-zi,boxzsize)
25062
25063         dist_init=xj**2+yj**2+zj**2
25064         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25065         rij  = dsqrt(rrij)
25066         dxj = dc_norm( 1,j )
25067         dyj = dc_norm( 2,j )
25068         dzj = dc_norm( 3,j )
25069         dscj_inv = vbld_inv(j+1)/2.0
25070 ! Gay-berne var's
25071         sig0ij = sigma_peppho
25072 !          chi1=0.0d0
25073 !          chi2=0.0d0
25074         chi12  = chi1 * chi2
25075 !          chip1=0.0d0
25076 !          chip2=0.0d0
25077         chip12 = chip1 * chip2
25078 !          chis1 = 0.0d0
25079 !          chis2 = 0.0d0
25080         chis12 = chis1 * chis2
25081         sig1 = sigmap1_peppho
25082         sig2 = sigmap2_peppho
25083 !       write (*,*) "sig1 = ", sig1
25084 !       write (*,*) "sig1 = ", sig1
25085 !       write (*,*) "sig2 = ", sig2
25086 ! alpha factors from Fcav/Gcav
25087         alf1   = 0.0d0
25088         alf2   = 0.0d0
25089         alf12  = 0.0d0
25090         b1 = alphasur_peppho(1)
25091 !          b1=0.0d0
25092         b2 = alphasur_peppho(2)
25093         b3 = alphasur_peppho(3)
25094         b4 = alphasur_peppho(4)
25095         CALL sc_angular
25096        sqom1=om1*om1
25097        evdwij = 0.0d0
25098        ECL = 0.0d0
25099        Elj = 0.0d0
25100        Equad = 0.0d0
25101        Epol = 0.0d0
25102        Fcav=0.0d0
25103        eheadtail = 0.0d0
25104        dGCLdR=0.0d0
25105        dGCLdOM1 = 0.0d0
25106        dGCLdOM2 = 0.0d0
25107        dGCLdOM12 = 0.0d0
25108        dPOLdOM1 = 0.0d0
25109        dPOLdOM2 = 0.0d0
25110         Fcav = 0.0d0
25111         dFdR = 0.0d0
25112         dCAVdOM1  = 0.0d0
25113         dCAVdOM2  = 0.0d0
25114         dCAVdOM12 = 0.0d0
25115         rij_shift = rij
25116         fac       = rij_shift**expon
25117         c1        = fac  * fac * aa_peppho
25118 !          c1        = 0.0d0
25119         c2        = fac  * bb_peppho
25120 !          c2        = 0.0d0
25121         evdwij    =  c1 + c2
25122 ! Now cavity....................
25123        eagle = dsqrt(1.0/rij_shift)
25124        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
25125         bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
25126         botsq = bot * bot
25127         Fcav = top / bot
25128         dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
25129         dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
25130         dFdR = ((dtop * bot - top * dbot) / botsq)
25131        w1        = wqdip_peppho(1)
25132        w2        = wqdip_peppho(2)
25133 !       w1=0.0d0
25134 !       w2=0.0d0
25135 !       pis       = sig0head_scbase(itypi,itypj)
25136 !       eps_head   = epshead_scbase(itypi,itypj)
25137 !c!-------------------------------------------------------------------
25138
25139 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25140 !c!     &        +dhead(1,1,itypi,itypj))**2))
25141 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25142 !c!     &        +dhead(2,1,itypi,itypj))**2))
25143
25144 !c!-------------------------------------------------------------------
25145 !c! ecl
25146        sparrow  = w1  *  om1
25147        hawk     = w2 *  (1.0d0 - sqom1)
25148        Ecl = sparrow * rij_shift**2.0d0 &
25149          - hawk    * rij_shift**4.0d0
25150 !c!-------------------------------------------------------------------
25151 !c! derivative of ecl is Gcl
25152 !c! dF/dr part
25153 !       rij_shift=5.0
25154        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
25155             + 4.0d0 * hawk    * rij_shift**5.0d0
25156 !c! dF/dom1
25157        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
25158 !c! dF/dom2
25159        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
25160        eom1  =    dGCLdOM1+dGCLdOM2
25161        eom2  =    0.0
25162
25163         fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
25164 !          fac=0.0
25165         gg(1) =  fac*xj*rij
25166         gg(2) =  fac*yj*rij
25167         gg(3) =  fac*zj*rij
25168        do k=1,3
25169        gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
25170        gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
25171        gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
25172        gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
25173        gg(k)=0.0
25174        enddo
25175
25176       DO k = 1, 3
25177       dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
25178       dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
25179       gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
25180       gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
25181 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25182       gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
25183 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25184       gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
25185              - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25186       gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
25187              + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25188       enddo
25189        epeppho=epeppho+evdwij+Fcav+ECL
25190 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
25191        enddo
25192        enddo
25193       end subroutine eprot_pep_phosphate
25194 !!!!!!!!!!!!!!!!-------------------------------------------------------------
25195       subroutine emomo(evdw)
25196       use calc_data
25197       use comm_momo
25198 !      implicit real*8 (a-h,o-z)
25199 !      include 'DIMENSIONS'
25200 !      include 'COMMON.GEO'
25201 !      include 'COMMON.VAR'
25202 !      include 'COMMON.LOCAL'
25203 !      include 'COMMON.CHAIN'
25204 !      include 'COMMON.DERIV'
25205 !      include 'COMMON.NAMES'
25206 !      include 'COMMON.INTERACT'
25207 !      include 'COMMON.IOUNITS'
25208 !      include 'COMMON.CALC'
25209 !      include 'COMMON.CONTROL'
25210 !      include 'COMMON.SBRIDGE'
25211       logical :: lprn
25212 !el local variables
25213       integer :: iint,itypi1,subchap,isel
25214       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
25215       real(kind=8) :: evdw,aa,bb
25216       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25217                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
25218                 sslipi,sslipj,faclip,alpha_sco
25219       integer :: ii
25220       real(kind=8) :: fracinbuf
25221        real (kind=8) :: escpho
25222        real (kind=8),dimension(4):: ener
25223        real(kind=8) :: b1,b2,egb
25224        real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
25225       Lambf,&
25226       Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
25227       dFdOM2,dFdL,dFdOM12,&
25228       federmaus,&
25229       d1i,d1j
25230 !       real(kind=8),dimension(3,2)::erhead_tail
25231 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
25232        real(kind=8) ::  facd4, adler, Fgb, facd3
25233        integer troll,jj,istate
25234        real (kind=8) :: dcosom1(3),dcosom2(3)
25235        evdw=0.0d0
25236        eps_out=80.0d0
25237        sss_ele_cut=1.0d0
25238 !       print *,"EVDW KURW",evdw,nres
25239       do i=iatsc_s,iatsc_e
25240 !        print *,"I am in EVDW",i
25241       itypi=iabs(itype(i,1))
25242 !        if (i.ne.47) cycle
25243       if (itypi.eq.ntyp1) cycle
25244       itypi1=iabs(itype(i+1,1))
25245       xi=c(1,nres+i)
25246       yi=c(2,nres+i)
25247       zi=c(3,nres+i)
25248         call to_box(xi,yi,zi)
25249         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
25250 !       endif
25251 !       print *, sslipi,ssgradlipi
25252       dxi=dc_norm(1,nres+i)
25253       dyi=dc_norm(2,nres+i)
25254       dzi=dc_norm(3,nres+i)
25255 !        dsci_inv=dsc_inv(itypi)
25256       dsci_inv=vbld_inv(i+nres)
25257 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
25258 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
25259 !
25260 ! Calculate SC interaction energy.
25261 !
25262       do iint=1,nint_gr(i)
25263         do j=istart(i,iint),iend(i,iint)
25264 !             print *,"JA PIER",i,j,iint,istart(i,iint),iend(i,iint)
25265           IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
25266             call dyn_ssbond_ene(i,j,evdwij)
25267             evdw=evdw+evdwij
25268             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25269                         'evdw',i,j,evdwij,' ss'
25270 !              if (energy_dec) write (iout,*) &
25271 !                              'evdw',i,j,evdwij,' ss'
25272            do k=j+1,iend(i,iint)
25273 !C search over all next residues
25274             if (dyn_ss_mask(k)) then
25275 !C check if they are cysteins
25276 !C              write(iout,*) 'k=',k
25277
25278 !c              write(iout,*) "PRZED TRI", evdwij
25279 !               evdwij_przed_tri=evdwij
25280             call triple_ssbond_ene(i,j,k,evdwij)
25281 !c               if(evdwij_przed_tri.ne.evdwij) then
25282 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
25283 !c               endif
25284
25285 !c              write(iout,*) "PO TRI", evdwij
25286 !C call the energy function that removes the artifical triple disulfide
25287 !C bond the soubroutine is located in ssMD.F
25288             evdw=evdw+evdwij
25289             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25290                       'evdw',i,j,evdwij,'tss'
25291             endif!dyn_ss_mask(k)
25292            enddo! k
25293           ELSE
25294 !el            ind=ind+1
25295           itypj=iabs(itype(j,1))
25296           if (itypj.eq.ntyp1) cycle
25297            CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
25298
25299 !             if (j.ne.78) cycle
25300 !            dscj_inv=dsc_inv(itypj)
25301           dscj_inv=vbld_inv(j+nres)
25302          xj=c(1,j+nres)
25303          yj=c(2,j+nres)
25304          zj=c(3,j+nres)
25305      call to_box(xj,yj,zj)
25306      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
25307       write(iout,*) "KRUWA", i,j
25308       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
25309       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
25310       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
25311       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
25312       xj=boxshift(xj-xi,boxxsize)
25313       yj=boxshift(yj-yi,boxysize)
25314       zj=boxshift(zj-zi,boxzsize)
25315         dxj = dc_norm( 1, nres+j )
25316         dyj = dc_norm( 2, nres+j )
25317         dzj = dc_norm( 3, nres+j )
25318 !          print *,i,j,itypi,itypj
25319 !          d1i=0.0d0
25320 !          d1j=0.0d0
25321 !          BetaT = 1.0d0 / (298.0d0 * Rb)
25322 ! Gay-berne var's
25323 !1!          sig0ij = sigma_scsc( itypi,itypj )
25324 !          chi1=0.0d0
25325 !          chi2=0.0d0
25326 !          chip1=0.0d0
25327 !          chip2=0.0d0
25328 ! not used by momo potential, but needed by sc_angular which is shared
25329 ! by all energy_potential subroutines
25330         alf1   = 0.0d0
25331         alf2   = 0.0d0
25332         alf12  = 0.0d0
25333         a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
25334 !       a12sq = a12sq * a12sq
25335 ! charge of amino acid itypi is...
25336         chis1 = chis(itypi,itypj)
25337         chis2 = chis(itypj,itypi)
25338         chis12 = chis1 * chis2
25339         sig1 = sigmap1(itypi,itypj)
25340         sig2 = sigmap2(itypi,itypj)
25341 !       write (*,*) "sig1 = ", sig1
25342 !          chis1=0.0
25343 !          chis2=0.0
25344 !                    chis12 = chis1 * chis2
25345 !          sig1=0.0
25346 !          sig2=0.0
25347 !       write (*,*) "sig2 = ", sig2
25348 ! alpha factors from Fcav/Gcav
25349         b1cav = alphasur(1,itypi,itypj)
25350 !          b1cav=0.0d0
25351         b2cav = alphasur(2,itypi,itypj)
25352         b3cav = alphasur(3,itypi,itypj)
25353         b4cav = alphasur(4,itypi,itypj)
25354 ! used to determine whether we want to do quadrupole calculations
25355        eps_in = epsintab(itypi,itypj)
25356        if (eps_in.eq.0.0) eps_in=1.0
25357
25358        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
25359        Rtail = 0.0d0
25360 !       dtail(1,itypi,itypj)=0.0
25361 !       dtail(2,itypi,itypj)=0.0
25362
25363        DO k = 1, 3
25364       ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
25365       ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
25366        END DO
25367 !c! tail distances will be themselves usefull elswhere
25368 !c1 (in Gcav, for example)
25369        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
25370        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
25371        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
25372        Rtail = dsqrt( &
25373         (Rtail_distance(1)*Rtail_distance(1)) &
25374       + (Rtail_distance(2)*Rtail_distance(2)) &
25375       + (Rtail_distance(3)*Rtail_distance(3)))
25376
25377 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
25378 !-------------------------------------------------------------------
25379 ! tail location and distance calculations
25380        d1 = dhead(1, 1, itypi, itypj)
25381        d2 = dhead(2, 1, itypi, itypj)
25382
25383        DO k = 1,3
25384 ! location of polar head is computed by taking hydrophobic centre
25385 ! and moving by a d1 * dc_norm vector
25386 ! see unres publications for very informative images
25387       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
25388       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
25389 ! distance
25390 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25391 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25392       Rhead_distance(k) = chead(k,2) - chead(k,1)
25393        END DO
25394 ! pitagoras (root of sum of squares)
25395        Rhead = dsqrt( &
25396         (Rhead_distance(1)*Rhead_distance(1)) &
25397       + (Rhead_distance(2)*Rhead_distance(2)) &
25398       + (Rhead_distance(3)*Rhead_distance(3)))
25399 !-------------------------------------------------------------------
25400 ! zero everything that should be zero'ed
25401        evdwij = 0.0d0
25402        ECL = 0.0d0
25403        Elj = 0.0d0
25404        Equad = 0.0d0
25405        Epol = 0.0d0
25406        Fcav=0.0d0
25407        eheadtail = 0.0d0
25408        dGCLdOM1 = 0.0d0
25409        dGCLdOM2 = 0.0d0
25410        dGCLdOM12 = 0.0d0
25411        dPOLdOM1 = 0.0d0
25412        dPOLdOM2 = 0.0d0
25413         Fcav = 0.0d0
25414         dFdR = 0.0d0
25415         dCAVdOM1  = 0.0d0
25416         dCAVdOM2  = 0.0d0
25417         dCAVdOM12 = 0.0d0
25418         dscj_inv = vbld_inv(j+nres)
25419 !          print *,i,j,dscj_inv,dsci_inv
25420 ! rij holds 1/(distance of Calpha atoms)
25421         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25422         rij  = dsqrt(rrij)
25423 !----------------------------
25424         CALL sc_angular
25425 ! this should be in elgrad_init but om's are calculated by sc_angular
25426 ! which in turn is used by older potentials
25427 ! om = omega, sqom = om^2
25428         sqom1  = om1 * om1
25429         sqom2  = om2 * om2
25430         sqom12 = om12 * om12
25431
25432 ! now we calculate EGB - Gey-Berne
25433 ! It will be summed up in evdwij and saved in evdw
25434         sigsq     = 1.0D0  / sigsq
25435         sig       = sig0ij * dsqrt(sigsq)
25436 !          rij_shift = 1.0D0  / rij - sig + sig0ij
25437         rij_shift = Rtail - sig + sig0ij
25438         IF (rij_shift.le.0.0D0) THEN
25439          evdw = 1.0D20
25440          RETURN
25441         END IF
25442         sigder = -sig * sigsq
25443         rij_shift = 1.0D0 / rij_shift
25444         fac       = rij_shift**expon
25445         c1        = fac  * fac * aa_aq(itypi,itypj)
25446 !          print *,"ADAM",aa_aq(itypi,itypj)
25447
25448 !          c1        = 0.0d0
25449         c2        = fac  * bb_aq(itypi,itypj)
25450 !          c2        = 0.0d0
25451         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
25452         eps2der   = eps3rt * evdwij
25453         eps3der   = eps2rt * evdwij
25454 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
25455         evdwij    = eps2rt * eps3rt * evdwij
25456 !#ifdef TSCSC
25457 !          IF (bb_aq(itypi,itypj).gt.0) THEN
25458 !           evdw_p = evdw_p + evdwij
25459 !          ELSE
25460 !           evdw_m = evdw_m + evdwij
25461 !          END IF
25462 !#else
25463         evdw = evdw  &
25464             + evdwij
25465 !#endif
25466
25467         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
25468         fac    = -expon * (c1 + evdwij) * rij_shift
25469         sigder = fac * sigder
25470 !          fac    = rij * fac
25471 ! Calculate distance derivative
25472         gg(1) =  fac
25473         gg(2) =  fac
25474         gg(3) =  fac
25475 !          if (b2.gt.0.0) then
25476         fac = chis1 * sqom1 + chis2 * sqom2 &
25477         - 2.0d0 * chis12 * om1 * om2 * om12
25478 ! we will use pom later in Gcav, so dont mess with it!
25479         pom = 1.0d0 - chis1 * chis2 * sqom12
25480         Lambf = (1.0d0 - (fac / pom))
25481 !          print *,"fac,pom",fac,pom,Lambf
25482         Lambf = dsqrt(Lambf)
25483         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
25484 !          print *,"sig1,sig2",sig1,sig2,itypi,itypj
25485 !       write (*,*) "sparrow = ", sparrow
25486         Chif = Rtail * sparrow
25487 !           print *,"rij,sparrow",rij , sparrow
25488         ChiLambf = Chif * Lambf
25489         eagle = dsqrt(ChiLambf)
25490         bat = ChiLambf ** 11.0d0
25491         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
25492         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
25493         botsq = bot * bot
25494 !          print *,top,bot,"bot,top",ChiLambf,Chif
25495         Fcav = top / bot
25496
25497        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
25498        dbot = 12.0d0 * b4cav * bat * Lambf
25499        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25500
25501         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
25502         dbot = 12.0d0 * b4cav * bat * Chif
25503         eagle = Lambf * pom
25504         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25505         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25506         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25507             * (chis2 * om2 * om12 - om1) / (eagle * pom)
25508
25509         dFdL = ((dtop * bot - top * dbot) / botsq)
25510 !       dFdL = 0.0d0
25511         dCAVdOM1  = dFdL * ( dFdOM1 )
25512         dCAVdOM2  = dFdL * ( dFdOM2 )
25513         dCAVdOM12 = dFdL * ( dFdOM12 )
25514
25515        DO k= 1, 3
25516       ertail(k) = Rtail_distance(k)/Rtail
25517        END DO
25518        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
25519        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
25520        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25521        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25522        DO k = 1, 3
25523 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25524 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25525       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25526       gvdwx(k,i) = gvdwx(k,i) &
25527               - (( dFdR + gg(k) ) * pom)
25528 !c!     &             - ( dFdR * pom )
25529       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25530       gvdwx(k,j) = gvdwx(k,j)   &
25531               + (( dFdR + gg(k) ) * pom)
25532 !c!     &             + ( dFdR * pom )
25533
25534       gvdwc(k,i) = gvdwc(k,i)  &
25535               - (( dFdR + gg(k) ) * ertail(k))
25536 !c!     &             - ( dFdR * ertail(k))
25537
25538       gvdwc(k,j) = gvdwc(k,j) &
25539               + (( dFdR + gg(k) ) * ertail(k))
25540 !c!     &             + ( dFdR * ertail(k))
25541
25542       gg(k) = 0.0d0
25543 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25544 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25545       END DO
25546
25547
25548 !c! Compute head-head and head-tail energies for each state
25549
25550         isel = iabs(Qi) + iabs(Qj)
25551 ! double charge for Phophorylated! itype - 25,27,27
25552 !          if ((itype(i).eq.27).or.(itype(i).eq.26).or.(itype(i).eq.25)) then
25553 !            Qi=Qi*2
25554 !            Qij=Qij*2
25555 !           endif
25556 !          if ((itype(j).eq.27).or.(itype(j).eq.26).or.(itype(j).eq.25)) then
25557 !            Qj=Qj*2
25558 !            Qij=Qij*2
25559 !           endif
25560
25561 !          isel=0
25562         IF (isel.eq.0) THEN
25563 !c! No charges - do nothing
25564          eheadtail = 0.0d0
25565
25566         ELSE IF (isel.eq.4) THEN
25567 !c! Calculate dipole-dipole interactions
25568          CALL edd(ecl)
25569          eheadtail = ECL
25570 !           eheadtail = 0.0d0
25571
25572         ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
25573 !c! Charge-nonpolar interactions
25574         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25575           Qi=Qi*2
25576           Qij=Qij*2
25577          endif
25578         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25579           Qj=Qj*2
25580           Qij=Qij*2
25581          endif
25582
25583          CALL eqn(epol)
25584          eheadtail = epol
25585 !           eheadtail = 0.0d0
25586
25587         ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
25588 !c! Nonpolar-charge interactions
25589         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25590           Qi=Qi*2
25591           Qij=Qij*2
25592          endif
25593         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25594           Qj=Qj*2
25595           Qij=Qij*2
25596          endif
25597
25598          CALL enq(epol)
25599          eheadtail = epol
25600 !           eheadtail = 0.0d0
25601
25602         ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
25603 !c! Charge-dipole interactions
25604         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25605           Qi=Qi*2
25606           Qij=Qij*2
25607          endif
25608         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25609           Qj=Qj*2
25610           Qij=Qij*2
25611          endif
25612
25613          CALL eqd(ecl, elj, epol)
25614          eheadtail = ECL + elj + epol
25615 !           eheadtail = 0.0d0
25616
25617         ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
25618 !c! Dipole-charge interactions
25619         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25620           Qi=Qi*2
25621           Qij=Qij*2
25622          endif
25623         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25624           Qj=Qj*2
25625           Qij=Qij*2
25626          endif
25627          CALL edq(ecl, elj, epol)
25628         eheadtail = ECL + elj + epol
25629 !           eheadtail = 0.0d0
25630
25631         ELSE IF ((isel.eq.2.and.   &
25632              iabs(Qi).eq.1).and.  &
25633              nstate(itypi,itypj).eq.1) THEN
25634 !c! Same charge-charge interaction ( +/+ or -/- )
25635         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25636           Qi=Qi*2
25637           Qij=Qij*2
25638          endif
25639         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25640           Qj=Qj*2
25641           Qij=Qij*2
25642          endif
25643
25644          CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
25645          eheadtail = ECL + Egb + Epol + Fisocav + Elj
25646 !           eheadtail = 0.0d0
25647
25648         ELSE IF ((isel.eq.2.and.  &
25649              iabs(Qi).eq.1).and. &
25650              nstate(itypi,itypj).ne.1) THEN
25651 !c! Different charge-charge interaction ( +/- or -/+ )
25652         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25653           Qi=Qi*2
25654           Qij=Qij*2
25655          endif
25656         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25657           Qj=Qj*2
25658           Qij=Qij*2
25659          endif
25660
25661          CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
25662         END IF
25663        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
25664       evdw = evdw  + Fcav + eheadtail
25665
25666        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
25667       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
25668       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
25669       Equad,evdwij+Fcav+eheadtail,evdw
25670 !       evdw = evdw  + Fcav  + eheadtail
25671
25672       iF (nstate(itypi,itypj).eq.1) THEN
25673       CALL sc_grad
25674        END IF
25675 !c!-------------------------------------------------------------------
25676 !c! NAPISY KONCOWE
25677        END DO   ! j
25678       END DO    ! iint
25679        END DO     ! i
25680 !c      write (iout,*) "Number of loop steps in EGB:",ind
25681 !c      energy_dec=.false.
25682 !              print *,"EVDW KURW",evdw,nres
25683
25684        RETURN
25685       END SUBROUTINE emomo
25686 !C------------------------------------------------------------------------------------
25687       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
25688       use calc_data
25689       use comm_momo
25690        real (kind=8) ::  facd3, facd4, federmaus, adler,&
25691        Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
25692 !       integer :: k
25693 !c! Epol and Gpol analytical parameters
25694        alphapol1 = alphapol(itypi,itypj)
25695        alphapol2 = alphapol(itypj,itypi)
25696 !c! Fisocav and Gisocav analytical parameters
25697        al1  = alphiso(1,itypi,itypj)
25698        al2  = alphiso(2,itypi,itypj)
25699        al3  = alphiso(3,itypi,itypj)
25700        al4  = alphiso(4,itypi,itypj)
25701        csig = (1.0d0  &
25702          / dsqrt(sigiso1(itypi, itypj)**2.0d0 &
25703          + sigiso2(itypi,itypj)**2.0d0))
25704 !c!
25705        pis  = sig0head(itypi,itypj)
25706        eps_head = epshead(itypi,itypj)
25707        Rhead_sq = Rhead * Rhead
25708 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25709 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25710        R1 = 0.0d0
25711        R2 = 0.0d0
25712        DO k = 1, 3
25713 !c! Calculate head-to-tail distances needed by Epol
25714       R1=R1+(ctail(k,2)-chead(k,1))**2
25715       R2=R2+(chead(k,2)-ctail(k,1))**2
25716        END DO
25717 !c! Pitagoras
25718        R1 = dsqrt(R1)
25719        R2 = dsqrt(R2)
25720
25721 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25722 !c!     &        +dhead(1,1,itypi,itypj))**2))
25723 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25724 !c!     &        +dhead(2,1,itypi,itypj))**2))
25725
25726 !c!-------------------------------------------------------------------
25727 !c! Coulomb electrostatic interaction
25728        Ecl = (332.0d0 * Qij) / Rhead
25729 !c! derivative of Ecl is Gcl...
25730        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
25731        dGCLdOM1 = 0.0d0
25732        dGCLdOM2 = 0.0d0
25733        dGCLdOM12 = 0.0d0
25734        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
25735        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
25736        debkap=debaykap(itypi,itypj)
25737        Egb = -(332.0d0 * Qij *&
25738       (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
25739 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
25740 !c! Derivative of Egb is Ggb...
25741        dGGBdFGB = -(-332.0d0 * Qij * &
25742        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
25743        -(332.0d0 * Qij *&
25744       (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
25745        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
25746        dGGBdR = dGGBdFGB * dFGBdR
25747 !c!-------------------------------------------------------------------
25748 !c! Fisocav - isotropic cavity creation term
25749 !c! or "how much energy it costs to put charged head in water"
25750        pom = Rhead * csig
25751        top = al1 * (dsqrt(pom) + al2 * pom - al3)
25752        bot = (1.0d0 + al4 * pom**12.0d0)
25753        botsq = bot * bot
25754        FisoCav = top / bot
25755 !      write (*,*) "Rhead = ",Rhead
25756 !      write (*,*) "csig = ",csig
25757 !      write (*,*) "pom = ",pom
25758 !      write (*,*) "al1 = ",al1
25759 !      write (*,*) "al2 = ",al2
25760 !      write (*,*) "al3 = ",al3
25761 !      write (*,*) "al4 = ",al4
25762 !        write (*,*) "top = ",top
25763 !        write (*,*) "bot = ",bot
25764 !c! Derivative of Fisocav is GCV...
25765        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
25766        dbot = 12.0d0 * al4 * pom ** 11.0d0
25767        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
25768 !c!-------------------------------------------------------------------
25769 !c! Epol
25770 !c! Polarization energy - charged heads polarize hydrophobic "neck"
25771        MomoFac1 = (1.0d0 - chi1 * sqom2)
25772        MomoFac2 = (1.0d0 - chi2 * sqom1)
25773        RR1  = ( R1 * R1 ) / MomoFac1
25774        RR2  = ( R2 * R2 ) / MomoFac2
25775        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25776        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
25777        fgb1 = sqrt( RR1 + a12sq * ee1 )
25778        fgb2 = sqrt( RR2 + a12sq * ee2 )
25779        epol = 332.0d0 * eps_inout_fac * ( &
25780       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
25781 !c!       epol = 0.0d0
25782        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
25783              / (fgb1 ** 5.0d0)
25784        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
25785              / (fgb2 ** 5.0d0)
25786        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
25787            / ( 2.0d0 * fgb1 )
25788        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
25789            / ( 2.0d0 * fgb2 )
25790        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
25791             * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
25792        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
25793             * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
25794        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25795 !c!       dPOLdR1 = 0.0d0
25796        dPOLdR2 = dPOLdFGB2 * dFGBdR2
25797 !c!       dPOLdR2 = 0.0d0
25798        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25799 !c!       dPOLdOM1 = 0.0d0
25800        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25801 !c!       dPOLdOM2 = 0.0d0
25802 !c!-------------------------------------------------------------------
25803 !c! Elj
25804 !c! Lennard-Jones 6-12 interaction between heads
25805        pom = (pis / Rhead)**6.0d0
25806        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25807 !c! derivative of Elj is Glj
25808        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
25809            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
25810 !c!-------------------------------------------------------------------
25811 !c! Return the results
25812 !c! These things do the dRdX derivatives, that is
25813 !c! allow us to change what we see from function that changes with
25814 !c! distance to function that changes with LOCATION (of the interaction
25815 !c! site)
25816        DO k = 1, 3
25817       erhead(k) = Rhead_distance(k)/Rhead
25818       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25819       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25820        END DO
25821
25822        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25823        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25824        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25825        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25826        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
25827        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25828        facd1 = d1 * vbld_inv(i+nres)
25829        facd2 = d2 * vbld_inv(j+nres)
25830        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25831        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25832
25833 !c! Now we add appropriate partial derivatives (one in each dimension)
25834        DO k = 1, 3
25835       hawk   = (erhead_tail(k,1) + &
25836       facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
25837       condor = (erhead_tail(k,2) + &
25838       facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
25839
25840       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25841       gvdwx(k,i) = gvdwx(k,i) &
25842               - dGCLdR * pom&
25843               - dGGBdR * pom&
25844               - dGCVdR * pom&
25845               - dPOLdR1 * hawk&
25846               - dPOLdR2 * (erhead_tail(k,2)&
25847       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
25848               - dGLJdR * pom
25849
25850       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25851       gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom&
25852                + dGGBdR * pom+ dGCVdR * pom&
25853               + dPOLdR1 * (erhead_tail(k,1)&
25854       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))&
25855               + dPOLdR2 * condor + dGLJdR * pom
25856
25857       gvdwc(k,i) = gvdwc(k,i)  &
25858               - dGCLdR * erhead(k)&
25859               - dGGBdR * erhead(k)&
25860               - dGCVdR * erhead(k)&
25861               - dPOLdR1 * erhead_tail(k,1)&
25862               - dPOLdR2 * erhead_tail(k,2)&
25863               - dGLJdR * erhead(k)
25864
25865       gvdwc(k,j) = gvdwc(k,j)         &
25866               + dGCLdR * erhead(k) &
25867               + dGGBdR * erhead(k) &
25868               + dGCVdR * erhead(k) &
25869               + dPOLdR1 * erhead_tail(k,1) &
25870               + dPOLdR2 * erhead_tail(k,2)&
25871               + dGLJdR * erhead(k)
25872
25873        END DO
25874        RETURN
25875       END SUBROUTINE eqq
25876
25877       SUBROUTINE eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
25878       use calc_data
25879       use comm_momo
25880        real (kind=8) ::  facd3, facd4, federmaus, adler,&
25881        Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
25882 !       integer :: k
25883 !c! Epol and Gpol analytical parameters
25884        alphapol1 = alphapolcat(itypi,itypj)
25885        alphapol2 = alphapolcat(itypj,itypi)
25886 !c! Fisocav and Gisocav analytical parameters
25887        al1  = alphisocat(1,itypi,itypj)
25888        al2  = alphisocat(2,itypi,itypj)
25889        al3  = alphisocat(3,itypi,itypj)
25890        al4  = alphisocat(4,itypi,itypj)
25891        csig = (1.0d0  &
25892          / dsqrt(sigiso1cat(itypi, itypj)**2.0d0 &
25893          + sigiso2cat(itypi,itypj)**2.0d0))
25894 !c!
25895        pis  = sig0headcat(itypi,itypj)
25896        eps_head = epsheadcat(itypi,itypj)
25897        Rhead_sq = Rhead * Rhead
25898 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25899 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25900        R1 = 0.0d0
25901        R2 = 0.0d0
25902        DO k = 1, 3
25903 !c! Calculate head-to-tail distances needed by Epol
25904       R1=R1+(ctail(k,2)-chead(k,1))**2
25905       R2=R2+(chead(k,2)-ctail(k,1))**2
25906        END DO
25907 !c! Pitagoras
25908        R1 = dsqrt(R1)
25909        R2 = dsqrt(R2)
25910
25911 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25912 !c!     &        +dhead(1,1,itypi,itypj))**2))
25913 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25914 !c!     &        +dhead(2,1,itypi,itypj))**2))
25915
25916 !c!-------------------------------------------------------------------
25917 !c! Coulomb electrostatic interaction
25918        Ecl = (332.0d0 * Qij) / Rhead
25919 !c! derivative of Ecl is Gcl...
25920        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
25921        dGCLdOM1 = 0.0d0
25922        dGCLdOM2 = 0.0d0
25923        dGCLdOM12 = 0.0d0
25924        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
25925        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
25926        debkap=debaykapcat(itypi,itypj)
25927        Egb = -(332.0d0 * Qij *&
25928       (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
25929 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
25930 !c! Derivative of Egb is Ggb...
25931        dGGBdFGB = -(-332.0d0 * Qij * &
25932        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
25933        -(332.0d0 * Qij *&
25934       (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
25935        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
25936        dGGBdR = dGGBdFGB * dFGBdR
25937 !c!-------------------------------------------------------------------
25938 !c! Fisocav - isotropic cavity creation term
25939 !c! or "how much energy it costs to put charged head in water"
25940        pom = Rhead * csig
25941        top = al1 * (dsqrt(pom) + al2 * pom - al3)
25942        bot = (1.0d0 + al4 * pom**12.0d0)
25943        botsq = bot * bot
25944        FisoCav = top / bot
25945 !      write (*,*) "Rhead = ",Rhead
25946 !      write (*,*) "csig = ",csig
25947 !      write (*,*) "pom = ",pom
25948 !      write (*,*) "al1 = ",al1
25949 !      write (*,*) "al2 = ",al2
25950 !      write (*,*) "al3 = ",al3
25951 !      write (*,*) "al4 = ",al4
25952 !        write (*,*) "top = ",top
25953 !        write (*,*) "bot = ",bot
25954 !c! Derivative of Fisocav is GCV...
25955        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
25956        dbot = 12.0d0 * al4 * pom ** 11.0d0
25957        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
25958 !c!-------------------------------------------------------------------
25959 !c! Epol
25960 !c! Polarization energy - charged heads polarize hydrophobic "neck"
25961        MomoFac1 = (1.0d0 - chi1 * sqom2)
25962        MomoFac2 = (1.0d0 - chi2 * sqom1)
25963        RR1  = ( R1 * R1 ) / MomoFac1
25964        RR2  = ( R2 * R2 ) / MomoFac2
25965        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25966        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
25967        fgb1 = sqrt( RR1 + a12sq * ee1 )
25968        fgb2 = sqrt( RR2 + a12sq * ee2 )
25969        epol = 332.0d0 * eps_inout_fac * ( &
25970       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
25971 !c!       epol = 0.0d0
25972        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
25973              / (fgb1 ** 5.0d0)
25974        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
25975              / (fgb2 ** 5.0d0)
25976        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
25977            / ( 2.0d0 * fgb1 )
25978        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
25979            / ( 2.0d0 * fgb2 )
25980        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
25981             * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
25982        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
25983             * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
25984        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25985 !c!       dPOLdR1 = 0.0d0
25986        dPOLdR2 = dPOLdFGB2 * dFGBdR2
25987 !c!       dPOLdR2 = 0.0d0
25988        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25989 !c!       dPOLdOM1 = 0.0d0
25990        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25991 !c!       dPOLdOM2 = 0.0d0
25992 !c!-------------------------------------------------------------------
25993 !c! Elj
25994 !c! Lennard-Jones 6-12 interaction between heads
25995        pom = (pis / Rhead)**6.0d0
25996        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25997 !c! derivative of Elj is Glj
25998        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
25999            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26000 !c!-------------------------------------------------------------------
26001 !c! Return the results
26002 !c! These things do the dRdX derivatives, that is
26003 !c! allow us to change what we see from function that changes with
26004 !c! distance to function that changes with LOCATION (of the interaction
26005 !c! site)
26006        DO k = 1, 3
26007       erhead(k) = Rhead_distance(k)/Rhead
26008       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26009       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26010        END DO
26011
26012        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26013        erdxj = scalar( erhead(1), dC_norm(1,j) )
26014        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26015        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
26016        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
26017        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26018        facd1 = d1 * vbld_inv(i+nres)
26019        facd2 = d2 * vbld_inv(j)
26020        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
26021        facd4 = dtailcat(2,itypi,itypj) * vbld_inv(j)
26022
26023 !c! Now we add appropriate partial derivatives (one in each dimension)
26024        DO k = 1, 3
26025       hawk   = (erhead_tail(k,1) + &
26026       facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
26027       condor = (erhead_tail(k,2) + &
26028       facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
26029
26030       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26031       gradpepcatx(k,i) = gradpepcatx(k,i) &
26032               - dGCLdR * pom&
26033               - dGGBdR * pom&
26034               - dGCVdR * pom&
26035               - dPOLdR1 * hawk&
26036               - dPOLdR2 * (erhead_tail(k,2)&
26037       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26038               - dGLJdR * pom
26039
26040       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
26041 !        gradpepcatx(k,j) = gradpepcatx(k,j)+ dGCLdR * pom&
26042 !                   + dGGBdR * pom+ dGCVdR * pom&
26043 !                  + dPOLdR1 * (erhead_tail(k,1)&
26044 !      -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j)))&
26045 !                  + dPOLdR2 * condor + dGLJdR * pom
26046
26047       gradpepcat(k,i) = gradpepcat(k,i)  &
26048               - dGCLdR * erhead(k)&
26049               - dGGBdR * erhead(k)&
26050               - dGCVdR * erhead(k)&
26051               - dPOLdR1 * erhead_tail(k,1)&
26052               - dPOLdR2 * erhead_tail(k,2)&
26053               - dGLJdR * erhead(k)
26054
26055       gradpepcat(k,j) = gradpepcat(k,j)         &
26056               + dGCLdR * erhead(k) &
26057               + dGGBdR * erhead(k) &
26058               + dGCVdR * erhead(k) &
26059               + dPOLdR1 * erhead_tail(k,1) &
26060               + dPOLdR2 * erhead_tail(k,2)&
26061               + dGLJdR * erhead(k)
26062
26063        END DO
26064        RETURN
26065       END SUBROUTINE eqq_cat
26066 !c!-------------------------------------------------------------------
26067       SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
26068       use comm_momo
26069       use calc_data
26070
26071        double precision eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad
26072        double precision ener(4)
26073        double precision dcosom1(3),dcosom2(3)
26074 !c! used in Epol derivatives
26075        double precision facd3, facd4
26076        double precision federmaus, adler
26077        integer istate,ii,jj
26078        real (kind=8) :: Fgb
26079 !       print *,"CALLING EQUAD"
26080 !c! Epol and Gpol analytical parameters
26081        alphapol1 = alphapol(itypi,itypj)
26082        alphapol2 = alphapol(itypj,itypi)
26083 !c! Fisocav and Gisocav analytical parameters
26084        al1  = alphiso(1,itypi,itypj)
26085        al2  = alphiso(2,itypi,itypj)
26086        al3  = alphiso(3,itypi,itypj)
26087        al4  = alphiso(4,itypi,itypj)
26088        csig = (1.0d0 / dsqrt(sigiso1(itypi, itypj)**2.0d0&
26089           + sigiso2(itypi,itypj)**2.0d0))
26090 !c!
26091        w1   = wqdip(1,itypi,itypj)
26092        w2   = wqdip(2,itypi,itypj)
26093        pis  = sig0head(itypi,itypj)
26094        eps_head = epshead(itypi,itypj)
26095 !c! First things first:
26096 !c! We need to do sc_grad's job with GB and Fcav
26097        eom1  = eps2der * eps2rt_om1 &
26098            - 2.0D0 * alf1 * eps3der&
26099            + sigder * sigsq_om1&
26100            + dCAVdOM1
26101        eom2  = eps2der * eps2rt_om2 &
26102            + 2.0D0 * alf2 * eps3der&
26103            + sigder * sigsq_om2&
26104            + dCAVdOM2
26105        eom12 =  evdwij  * eps1_om12 &
26106            + eps2der * eps2rt_om12 &
26107            - 2.0D0 * alf12 * eps3der&
26108            + sigder *sigsq_om12&
26109            + dCAVdOM12
26110 !c! now some magical transformations to project gradient into
26111 !c! three cartesian vectors
26112        DO k = 1, 3
26113       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
26114       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
26115       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
26116 !c! this acts on hydrophobic center of interaction
26117       gvdwx(k,i)= gvdwx(k,i) - gg(k) &
26118               + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
26119               + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26120       gvdwx(k,j)= gvdwx(k,j) + gg(k) &
26121               + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))&
26122               + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26123 !c! this acts on Calpha
26124       gvdwc(k,i)=gvdwc(k,i)-gg(k)
26125       gvdwc(k,j)=gvdwc(k,j)+gg(k)
26126        END DO
26127 !c! sc_grad is done, now we will compute
26128        eheadtail = 0.0d0
26129        eom1 = 0.0d0
26130        eom2 = 0.0d0
26131        eom12 = 0.0d0
26132        DO istate = 1, nstate(itypi,itypj)
26133 !c*************************************************************
26134       IF (istate.ne.1) THEN
26135        IF (istate.lt.3) THEN
26136         ii = 1
26137        ELSE
26138         ii = 2
26139        END IF
26140       jj = istate/ii
26141       d1 = dhead(1,ii,itypi,itypj)
26142       d2 = dhead(2,jj,itypi,itypj)
26143       DO k = 1,3
26144        chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
26145        chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
26146        Rhead_distance(k) = chead(k,2) - chead(k,1)
26147       END DO
26148 !c! pitagoras (root of sum of squares)
26149       Rhead = dsqrt( &
26150              (Rhead_distance(1)*Rhead_distance(1))  &
26151            + (Rhead_distance(2)*Rhead_distance(2))  &
26152            + (Rhead_distance(3)*Rhead_distance(3)))
26153       END IF
26154       Rhead_sq = Rhead * Rhead
26155
26156 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26157 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26158       R1 = 0.0d0
26159       R2 = 0.0d0
26160       DO k = 1, 3
26161 !c! Calculate head-to-tail distances
26162        R1=R1+(ctail(k,2)-chead(k,1))**2
26163        R2=R2+(chead(k,2)-ctail(k,1))**2
26164       END DO
26165 !c! Pitagoras
26166       R1 = dsqrt(R1)
26167       R2 = dsqrt(R2)
26168       Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
26169 !c!        Ecl = 0.0d0
26170 !c!        write (*,*) "Ecl = ", Ecl
26171 !c! derivative of Ecl is Gcl...
26172       dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
26173 !c!        dGCLdR = 0.0d0
26174       dGCLdOM1 = 0.0d0
26175       dGCLdOM2 = 0.0d0
26176       dGCLdOM12 = 0.0d0
26177 !c!-------------------------------------------------------------------
26178 !c! Generalised Born Solvent Polarization
26179       ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26180       Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26181       Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
26182 !c!        Egb = 0.0d0
26183 !c!      write (*,*) "a1*a2 = ", a12sq
26184 !c!      write (*,*) "Rhead = ", Rhead
26185 !c!      write (*,*) "Rhead_sq = ", Rhead_sq
26186 !c!      write (*,*) "ee = ", ee
26187 !c!      write (*,*) "Fgb = ", Fgb
26188 !c!      write (*,*) "fac = ", eps_inout_fac
26189 !c!      write (*,*) "Qij = ", Qij
26190 !c!      write (*,*) "Egb = ", Egb
26191 !c! Derivative of Egb is Ggb...
26192 !c! dFGBdR is used by Quad's later...
26193       dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
26194       dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )&
26195              / ( 2.0d0 * Fgb )
26196       dGGBdR = dGGBdFGB * dFGBdR
26197 !c!        dGGBdR = 0.0d0
26198 !c!-------------------------------------------------------------------
26199 !c! Fisocav - isotropic cavity creation term
26200       pom = Rhead * csig
26201       top = al1 * (dsqrt(pom) + al2 * pom - al3)
26202       bot = (1.0d0 + al4 * pom**12.0d0)
26203       botsq = bot * bot
26204       FisoCav = top / bot
26205       dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26206       dbot = 12.0d0 * al4 * pom ** 11.0d0
26207       dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26208 !c!        dGCVdR = 0.0d0
26209 !c!-------------------------------------------------------------------
26210 !c! Polarization energy
26211 !c! Epol
26212       MomoFac1 = (1.0d0 - chi1 * sqom2)
26213       MomoFac2 = (1.0d0 - chi2 * sqom1)
26214       RR1  = ( R1 * R1 ) / MomoFac1
26215       RR2  = ( R2 * R2 ) / MomoFac2
26216       ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26217       ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26218       fgb1 = sqrt( RR1 + a12sq * ee1 )
26219       fgb2 = sqrt( RR2 + a12sq * ee2 )
26220       epol = 332.0d0 * eps_inout_fac * (&
26221       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26222 !c!        epol = 0.0d0
26223 !c! derivative of Epol is Gpol...
26224       dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26225               / (fgb1 ** 5.0d0)
26226       dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26227               / (fgb2 ** 5.0d0)
26228       dFGBdR1 = ( (R1 / MomoFac1) &
26229             * ( 2.0d0 - (0.5d0 * ee1) ) )&
26230             / ( 2.0d0 * fgb1 )
26231       dFGBdR2 = ( (R2 / MomoFac2) &
26232             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26233             / ( 2.0d0 * fgb2 )
26234       dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26235              * ( 2.0d0 - 0.5d0 * ee1) ) &
26236              / ( 2.0d0 * fgb1 )
26237       dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26238              * ( 2.0d0 - 0.5d0 * ee2) ) &
26239              / ( 2.0d0 * fgb2 )
26240       dPOLdR1 = dPOLdFGB1 * dFGBdR1
26241 !c!        dPOLdR1 = 0.0d0
26242       dPOLdR2 = dPOLdFGB2 * dFGBdR2
26243 !c!        dPOLdR2 = 0.0d0
26244       dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26245 !c!        dPOLdOM1 = 0.0d0
26246       dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26247       pom = (pis / Rhead)**6.0d0
26248       Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26249 !c!        Elj = 0.0d0
26250 !c! derivative of Elj is Glj
26251       dGLJdR = 4.0d0 * eps_head &
26252           * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26253           +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26254 !c!        dGLJdR = 0.0d0
26255 !c!-------------------------------------------------------------------
26256 !c! Equad
26257        IF (Wqd.ne.0.0d0) THEN
26258       Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) &
26259            - 37.5d0  * ( sqom1 + sqom2 ) &
26260            + 157.5d0 * ( sqom1 * sqom2 ) &
26261            - 45.0d0  * om1*om2*om12
26262       fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
26263       Equad = fac * Beta1
26264 !c!        Equad = 0.0d0
26265 !c! derivative of Equad...
26266       dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
26267 !c!        dQUADdR = 0.0d0
26268       dQUADdOM1 = fac* (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
26269 !c!        dQUADdOM1 = 0.0d0
26270       dQUADdOM2 = fac* (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
26271 !c!        dQUADdOM2 = 0.0d0
26272       dQUADdOM12 = fac * ( 6.0d0*om12 - 45.0d0*om1*om2 )
26273        ELSE
26274        Beta1 = 0.0d0
26275        Equad = 0.0d0
26276       END IF
26277 !c!-------------------------------------------------------------------
26278 !c! Return the results
26279 !c! Angular stuff
26280       eom1 = dPOLdOM1 + dQUADdOM1
26281       eom2 = dPOLdOM2 + dQUADdOM2
26282       eom12 = dQUADdOM12
26283 !c! now some magical transformations to project gradient into
26284 !c! three cartesian vectors
26285       DO k = 1, 3
26286        dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
26287        dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
26288        tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
26289       END DO
26290 !c! Radial stuff
26291       DO k = 1, 3
26292        erhead(k) = Rhead_distance(k)/Rhead
26293        erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26294        erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26295       END DO
26296       erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26297       erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26298       bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26299       federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26300       eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26301       adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26302       facd1 = d1 * vbld_inv(i+nres)
26303       facd2 = d2 * vbld_inv(j+nres)
26304       facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26305       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26306       DO k = 1, 3
26307        hawk   = erhead_tail(k,1) + &
26308        facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
26309        condor = erhead_tail(k,2) + &
26310        facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
26311
26312        pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26313 !c! this acts on hydrophobic center of interaction
26314        gheadtail(k,1,1) = gheadtail(k,1,1) &
26315                    - dGCLdR * pom &
26316                    - dGGBdR * pom &
26317                    - dGCVdR * pom &
26318                    - dPOLdR1 * hawk &
26319                    - dPOLdR2 * (erhead_tail(k,2) &
26320       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26321                    - dGLJdR * pom &
26322                    - dQUADdR * pom&
26323                    - tuna(k) &
26324              + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
26325              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26326
26327        pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26328 !c! this acts on hydrophobic center of interaction
26329        gheadtail(k,2,1) = gheadtail(k,2,1)  &
26330                    + dGCLdR * pom      &
26331                    + dGGBdR * pom      &
26332                    + dGCVdR * pom      &
26333                    + dPOLdR1 * (erhead_tail(k,1) &
26334       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
26335                    + dPOLdR2 * condor &
26336                    + dGLJdR * pom &
26337                    + dQUADdR * pom &
26338                    + tuna(k) &
26339              + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
26340              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26341
26342 !c! this acts on Calpha
26343        gheadtail(k,3,1) = gheadtail(k,3,1)  &
26344                    - dGCLdR * erhead(k)&
26345                    - dGGBdR * erhead(k)&
26346                    - dGCVdR * erhead(k)&
26347                    - dPOLdR1 * erhead_tail(k,1)&
26348                    - dPOLdR2 * erhead_tail(k,2)&
26349                    - dGLJdR * erhead(k) &
26350                    - dQUADdR * erhead(k)&
26351                    - tuna(k)
26352 !c! this acts on Calpha
26353        gheadtail(k,4,1) = gheadtail(k,4,1)   &
26354                     + dGCLdR * erhead(k) &
26355                     + dGGBdR * erhead(k) &
26356                     + dGCVdR * erhead(k) &
26357                     + dPOLdR1 * erhead_tail(k,1) &
26358                     + dPOLdR2 * erhead_tail(k,2) &
26359                     + dGLJdR * erhead(k) &
26360                     + dQUADdR * erhead(k)&
26361                     + tuna(k)
26362       END DO
26363       ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
26364       eheadtail = eheadtail &
26365               + wstate(istate, itypi, itypj) &
26366               * dexp(-betaT * ener(istate))
26367 !c! foreach cartesian dimension
26368       DO k = 1, 3
26369 !c! foreach of two gvdwx and gvdwc
26370        DO l = 1, 4
26371         gheadtail(k,l,2) = gheadtail(k,l,2)  &
26372                      + wstate( istate, itypi, itypj ) &
26373                      * dexp(-betaT * ener(istate)) &
26374                      * gheadtail(k,l,1)
26375         gheadtail(k,l,1) = 0.0d0
26376        END DO
26377       END DO
26378        END DO
26379 !c! Here ended the gigantic DO istate = 1, 4, which starts
26380 !c! at the beggining of the subroutine
26381
26382        DO k = 1, 3
26383       DO l = 1, 4
26384        gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
26385       END DO
26386       gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
26387       gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
26388       gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
26389       gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
26390       DO l = 1, 4
26391        gheadtail(k,l,1) = 0.0d0
26392        gheadtail(k,l,2) = 0.0d0
26393       END DO
26394        END DO
26395        eheadtail = (-dlog(eheadtail)) / betaT
26396        dPOLdOM1 = 0.0d0
26397        dPOLdOM2 = 0.0d0
26398        dQUADdOM1 = 0.0d0
26399        dQUADdOM2 = 0.0d0
26400        dQUADdOM12 = 0.0d0
26401        RETURN
26402       END SUBROUTINE energy_quad
26403 !!-----------------------------------------------------------
26404       SUBROUTINE eqn(Epol)
26405       use comm_momo
26406       use calc_data
26407
26408       double precision  facd4, federmaus,epol
26409       alphapol1 = alphapol(itypi,itypj)
26410 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26411        R1 = 0.0d0
26412        DO k = 1, 3
26413 !c! Calculate head-to-tail distances
26414       R1=R1+(ctail(k,2)-chead(k,1))**2
26415        END DO
26416 !c! Pitagoras
26417        R1 = dsqrt(R1)
26418
26419 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26420 !c!     &        +dhead(1,1,itypi,itypj))**2))
26421 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26422 !c!     &        +dhead(2,1,itypi,itypj))**2))
26423 !c--------------------------------------------------------------------
26424 !c Polarization energy
26425 !c Epol
26426        MomoFac1 = (1.0d0 - chi1 * sqom2)
26427        RR1  = R1 * R1 / MomoFac1
26428        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26429        fgb1 = sqrt( RR1 + a12sq * ee1)
26430        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26431        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26432              / (fgb1 ** 5.0d0)
26433        dFGBdR1 = ( (R1 / MomoFac1) &
26434             * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26435             / ( 2.0d0 * fgb1 )
26436        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26437             * (2.0d0 - 0.5d0 * ee1) ) &
26438             / (2.0d0 * fgb1)
26439        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26440 !c!       dPOLdR1 = 0.0d0
26441        dPOLdOM1 = 0.0d0
26442        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26443        DO k = 1, 3
26444       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26445        END DO
26446        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26447        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26448        facd1 = d1 * vbld_inv(i+nres)
26449        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26450
26451        DO k = 1, 3
26452       hawk = (erhead_tail(k,1) + &
26453       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26454
26455       gvdwx(k,i) = gvdwx(k,i) &
26456                - dPOLdR1 * hawk
26457       gvdwx(k,j) = gvdwx(k,j) &
26458                + dPOLdR1 * (erhead_tail(k,1) &
26459        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
26460
26461       gvdwc(k,i) = gvdwc(k,i)  - dPOLdR1 * erhead_tail(k,1)
26462       gvdwc(k,j) = gvdwc(k,j)  + dPOLdR1 * erhead_tail(k,1)
26463
26464        END DO
26465        RETURN
26466       END SUBROUTINE eqn
26467       SUBROUTINE enq(Epol)
26468       use calc_data
26469       use comm_momo
26470        double precision facd3, adler,epol
26471        alphapol2 = alphapol(itypj,itypi)
26472 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26473        R2 = 0.0d0
26474        DO k = 1, 3
26475 !c! Calculate head-to-tail distances
26476       R2=R2+(chead(k,2)-ctail(k,1))**2
26477        END DO
26478 !c! Pitagoras
26479        R2 = dsqrt(R2)
26480
26481 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26482 !c!     &        +dhead(1,1,itypi,itypj))**2))
26483 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26484 !c!     &        +dhead(2,1,itypi,itypj))**2))
26485 !c------------------------------------------------------------------------
26486 !c Polarization energy
26487        MomoFac2 = (1.0d0 - chi2 * sqom1)
26488        RR2  = R2 * R2 / MomoFac2
26489        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26490        fgb2 = sqrt(RR2  + a12sq * ee2)
26491        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26492        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26493             / (fgb2 ** 5.0d0)
26494        dFGBdR2 = ( (R2 / MomoFac2)  &
26495             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26496             / (2.0d0 * fgb2)
26497        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26498             * (2.0d0 - 0.5d0 * ee2) ) &
26499             / (2.0d0 * fgb2)
26500        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26501 !c!       dPOLdR2 = 0.0d0
26502        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26503 !c!       dPOLdOM1 = 0.0d0
26504        dPOLdOM2 = 0.0d0
26505 !c!-------------------------------------------------------------------
26506 !c! Return the results
26507 !c! (See comments in Eqq)
26508        DO k = 1, 3
26509       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26510        END DO
26511        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26512        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26513        facd2 = d2 * vbld_inv(j+nres)
26514        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26515        DO k = 1, 3
26516       condor = (erhead_tail(k,2) &
26517        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26518
26519       gvdwx(k,i) = gvdwx(k,i) &
26520                - dPOLdR2 * (erhead_tail(k,2) &
26521        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
26522       gvdwx(k,j) = gvdwx(k,j)   &
26523                + dPOLdR2 * condor
26524
26525       gvdwc(k,i) = gvdwc(k,i) &
26526                - dPOLdR2 * erhead_tail(k,2)
26527       gvdwc(k,j) = gvdwc(k,j) &
26528                + dPOLdR2 * erhead_tail(k,2)
26529
26530        END DO
26531       RETURN
26532       END SUBROUTINE enq
26533
26534       SUBROUTINE enq_cat(Epol)
26535       use calc_data
26536       use comm_momo
26537        double precision facd3, adler,epol
26538        alphapol2 = alphapolcat(itypj,itypi)
26539 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26540        R2 = 0.0d0
26541        DO k = 1, 3
26542 !c! Calculate head-to-tail distances
26543       R2=R2+(chead(k,2)-ctail(k,1))**2
26544        END DO
26545 !c! Pitagoras
26546        R2 = dsqrt(R2)
26547
26548 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26549 !c!     &        +dhead(1,1,itypi,itypj))**2))
26550 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26551 !c!     &        +dhead(2,1,itypi,itypj))**2))
26552 !c------------------------------------------------------------------------
26553 !c Polarization energy
26554        MomoFac2 = (1.0d0 - chi2 * sqom1)
26555        RR2  = R2 * R2 / MomoFac2
26556        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26557        fgb2 = sqrt(RR2  + a12sq * ee2)
26558        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26559        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26560             / (fgb2 ** 5.0d0)
26561        dFGBdR2 = ( (R2 / MomoFac2)  &
26562             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26563             / (2.0d0 * fgb2)
26564        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26565             * (2.0d0 - 0.5d0 * ee2) ) &
26566             / (2.0d0 * fgb2)
26567        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26568 !c!       dPOLdR2 = 0.0d0
26569        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26570 !c!       dPOLdOM1 = 0.0d0
26571        dPOLdOM2 = 0.0d0
26572
26573 !c!-------------------------------------------------------------------
26574 !c! Return the results
26575 !c! (See comments in Eqq)
26576        DO k = 1, 3
26577       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26578        END DO
26579        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
26580        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26581        facd2 = d2 * vbld_inv(j+nres)
26582        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
26583        DO k = 1, 3
26584       condor = (erhead_tail(k,2) &
26585        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
26586
26587       gradpepcatx(k,i) = gradpepcatx(k,i) &
26588                - dPOLdR2 * (erhead_tail(k,2) &
26589        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
26590 !        gradpepcatx(k,j) = gradpepcatx(k,j)   &
26591 !                   + dPOLdR2 * condor
26592
26593       gradpepcat(k,i) = gradpepcat(k,i) &
26594                - dPOLdR2 * erhead_tail(k,2)
26595       gradpepcat(k,j) = gradpepcat(k,j) &
26596                + dPOLdR2 * erhead_tail(k,2)
26597
26598        END DO
26599       RETURN
26600       END SUBROUTINE enq_cat
26601
26602       SUBROUTINE eqd(Ecl,Elj,Epol)
26603       use calc_data
26604       use comm_momo
26605        double precision  facd4, federmaus,ecl,elj,epol
26606        alphapol1 = alphapol(itypi,itypj)
26607        w1        = wqdip(1,itypi,itypj)
26608        w2        = wqdip(2,itypi,itypj)
26609        pis       = sig0head(itypi,itypj)
26610        eps_head   = epshead(itypi,itypj)
26611 !c!-------------------------------------------------------------------
26612 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26613        R1 = 0.0d0
26614        DO k = 1, 3
26615 !c! Calculate head-to-tail distances
26616       R1=R1+(ctail(k,2)-chead(k,1))**2
26617        END DO
26618 !c! Pitagoras
26619        R1 = dsqrt(R1)
26620
26621 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26622 !c!     &        +dhead(1,1,itypi,itypj))**2))
26623 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26624 !c!     &        +dhead(2,1,itypi,itypj))**2))
26625
26626 !c!-------------------------------------------------------------------
26627 !c! ecl
26628        sparrow  = w1 * Qi * om1
26629        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
26630        Ecl = sparrow / Rhead**2.0d0 &
26631          - hawk    / Rhead**4.0d0
26632        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26633              + 4.0d0 * hawk    / Rhead**5.0d0
26634 !c! dF/dom1
26635        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
26636 !c! dF/dom2
26637        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
26638 !c--------------------------------------------------------------------
26639 !c Polarization energy
26640 !c Epol
26641        MomoFac1 = (1.0d0 - chi1 * sqom2)
26642        RR1  = R1 * R1 / MomoFac1
26643        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26644        fgb1 = sqrt( RR1 + a12sq * ee1)
26645        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26646 !c!       epol = 0.0d0
26647 !c!------------------------------------------------------------------
26648 !c! derivative of Epol is Gpol...
26649        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26650              / (fgb1 ** 5.0d0)
26651        dFGBdR1 = ( (R1 / MomoFac1)  &
26652            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26653            / ( 2.0d0 * fgb1 )
26654        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26655              * (2.0d0 - 0.5d0 * ee1) ) &
26656              / (2.0d0 * fgb1)
26657        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26658 !c!       dPOLdR1 = 0.0d0
26659        dPOLdOM1 = 0.0d0
26660        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26661 !c!       dPOLdOM2 = 0.0d0
26662 !c!-------------------------------------------------------------------
26663 !c! Elj
26664        pom = (pis / Rhead)**6.0d0
26665        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26666 !c! derivative of Elj is Glj
26667        dGLJdR = 4.0d0 * eps_head &
26668         * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26669         +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26670        DO k = 1, 3
26671       erhead(k) = Rhead_distance(k)/Rhead
26672       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26673        END DO
26674
26675        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26676        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26677        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26678        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26679        facd1 = d1 * vbld_inv(i+nres)
26680        facd2 = d2 * vbld_inv(j+nres)
26681        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26682
26683        DO k = 1, 3
26684       hawk = (erhead_tail(k,1) +  &
26685       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26686
26687       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26688       gvdwx(k,i) = gvdwx(k,i)  &
26689                - dGCLdR * pom&
26690                - dPOLdR1 * hawk &
26691                - dGLJdR * pom
26692
26693       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26694       gvdwx(k,j) = gvdwx(k,j)    &
26695                + dGCLdR * pom  &
26696                + dPOLdR1 * (erhead_tail(k,1) &
26697        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
26698                + dGLJdR * pom
26699
26700
26701       gvdwc(k,i) = gvdwc(k,i)          &
26702                - dGCLdR * erhead(k)  &
26703                - dPOLdR1 * erhead_tail(k,1) &
26704                - dGLJdR * erhead(k)
26705
26706       gvdwc(k,j) = gvdwc(k,j)          &
26707                + dGCLdR * erhead(k)  &
26708                + dPOLdR1 * erhead_tail(k,1) &
26709                + dGLJdR * erhead(k)
26710
26711        END DO
26712        RETURN
26713       END SUBROUTINE eqd
26714       SUBROUTINE edq(Ecl,Elj,Epol)
26715 !       IMPLICIT NONE
26716        use comm_momo
26717       use calc_data
26718
26719       double precision  facd3, adler,ecl,elj,epol
26720        alphapol2 = alphapol(itypj,itypi)
26721        w1        = wqdip(1,itypi,itypj)
26722        w2        = wqdip(2,itypi,itypj)
26723        pis       = sig0head(itypi,itypj)
26724        eps_head  = epshead(itypi,itypj)
26725 !c!-------------------------------------------------------------------
26726 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26727        R2 = 0.0d0
26728        DO k = 1, 3
26729 !c! Calculate head-to-tail distances
26730       R2=R2+(chead(k,2)-ctail(k,1))**2
26731        END DO
26732 !c! Pitagoras
26733        R2 = dsqrt(R2)
26734
26735 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26736 !c!     &        +dhead(1,1,itypi,itypj))**2))
26737 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26738 !c!     &        +dhead(2,1,itypi,itypj))**2))
26739
26740
26741 !c!-------------------------------------------------------------------
26742 !c! ecl
26743        sparrow  = w1 * Qj * om1
26744        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
26745        ECL = sparrow / Rhead**2.0d0 &
26746          - hawk    / Rhead**4.0d0
26747 !c!-------------------------------------------------------------------
26748 !c! derivative of ecl is Gcl
26749 !c! dF/dr part
26750        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26751              + 4.0d0 * hawk    / Rhead**5.0d0
26752 !c! dF/dom1
26753        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
26754 !c! dF/dom2
26755        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
26756 !c--------------------------------------------------------------------
26757 !c Polarization energy
26758 !c Epol
26759        MomoFac2 = (1.0d0 - chi2 * sqom1)
26760        RR2  = R2 * R2 / MomoFac2
26761        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26762        fgb2 = sqrt(RR2  + a12sq * ee2)
26763        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26764        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26765              / (fgb2 ** 5.0d0)
26766        dFGBdR2 = ( (R2 / MomoFac2)  &
26767              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26768              / (2.0d0 * fgb2)
26769        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26770             * (2.0d0 - 0.5d0 * ee2) ) &
26771             / (2.0d0 * fgb2)
26772        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26773 !c!       dPOLdR2 = 0.0d0
26774        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26775 !c!       dPOLdOM1 = 0.0d0
26776        dPOLdOM2 = 0.0d0
26777 !c!-------------------------------------------------------------------
26778 !c! Elj
26779        pom = (pis / Rhead)**6.0d0
26780        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26781 !c! derivative of Elj is Glj
26782        dGLJdR = 4.0d0 * eps_head &
26783          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26784          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26785 !c!-------------------------------------------------------------------
26786 !c! Return the results
26787 !c! (see comments in Eqq)
26788        DO k = 1, 3
26789       erhead(k) = Rhead_distance(k)/Rhead
26790       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26791        END DO
26792        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26793        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26794        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26795        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26796        facd1 = d1 * vbld_inv(i+nres)
26797        facd2 = d2 * vbld_inv(j+nres)
26798        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26799        DO k = 1, 3
26800       condor = (erhead_tail(k,2) &
26801        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26802
26803       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26804       gvdwx(k,i) = gvdwx(k,i) &
26805               - dGCLdR * pom &
26806               - dPOLdR2 * (erhead_tail(k,2) &
26807        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
26808               - dGLJdR * pom
26809
26810       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26811       gvdwx(k,j) = gvdwx(k,j) &
26812               + dGCLdR * pom &
26813               + dPOLdR2 * condor &
26814               + dGLJdR * pom
26815
26816
26817       gvdwc(k,i) = gvdwc(k,i) &
26818               - dGCLdR * erhead(k) &
26819               - dPOLdR2 * erhead_tail(k,2) &
26820               - dGLJdR * erhead(k)
26821
26822       gvdwc(k,j) = gvdwc(k,j) &
26823               + dGCLdR * erhead(k) &
26824               + dPOLdR2 * erhead_tail(k,2) &
26825               + dGLJdR * erhead(k)
26826
26827        END DO
26828        RETURN
26829       END SUBROUTINE edq
26830
26831       SUBROUTINE edq_cat(Ecl,Elj,Epol)
26832       use comm_momo
26833       use calc_data
26834
26835       double precision  facd3, adler,ecl,elj,epol
26836        alphapol2 = alphapolcat(itypj,itypi)
26837        w1        = wqdipcat(1,itypi,itypj)
26838        w2        = wqdipcat(2,itypi,itypj)
26839        pis       = sig0headcat(itypi,itypj)
26840        eps_head  = epsheadcat(itypi,itypj)
26841 !c!-------------------------------------------------------------------
26842 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26843        R2 = 0.0d0
26844        DO k = 1, 3
26845 !c! Calculate head-to-tail distances
26846       R2=R2+(chead(k,2)-ctail(k,1))**2
26847        END DO
26848 !c! Pitagoras
26849        R2 = dsqrt(R2)
26850
26851 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26852 !c!     &        +dhead(1,1,itypi,itypj))**2))
26853 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26854 !c!     &        +dhead(2,1,itypi,itypj))**2))
26855
26856
26857 !c!-------------------------------------------------------------------
26858 !c! ecl
26859 !       write(iout,*) "KURWA2",Rhead
26860        sparrow  = w1 * Qj * om1
26861        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
26862        ECL = sparrow / Rhead**2.0d0 &
26863          - hawk    / Rhead**4.0d0
26864 !c!-------------------------------------------------------------------
26865 !c! derivative of ecl is Gcl
26866 !c! dF/dr part
26867        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26868              + 4.0d0 * hawk    / Rhead**5.0d0
26869 !c! dF/dom1
26870        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
26871 !c! dF/dom2
26872        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
26873 !c--------------------------------------------------------------------
26874 !c--------------------------------------------------------------------
26875 !c Polarization energy
26876 !c Epol
26877        MomoFac2 = (1.0d0 - chi2 * sqom1)
26878        RR2  = R2 * R2 / MomoFac2
26879        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26880        fgb2 = sqrt(RR2  + a12sq * ee2)
26881        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26882        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26883              / (fgb2 ** 5.0d0)
26884        dFGBdR2 = ( (R2 / MomoFac2)  &
26885              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26886              / (2.0d0 * fgb2)
26887        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26888             * (2.0d0 - 0.5d0 * ee2) ) &
26889             / (2.0d0 * fgb2)
26890        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26891 !c!       dPOLdR2 = 0.0d0
26892        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26893 !c!       dPOLdOM1 = 0.0d0
26894        dPOLdOM2 = 0.0d0
26895 !c!-------------------------------------------------------------------
26896 !c! Elj
26897        pom = (pis / Rhead)**6.0d0
26898        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26899 !c! derivative of Elj is Glj
26900        dGLJdR = 4.0d0 * eps_head &
26901          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26902          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26903 !c!-------------------------------------------------------------------
26904
26905 !c! Return the results
26906 !c! (see comments in Eqq)
26907        DO k = 1, 3
26908       erhead(k) = Rhead_distance(k)/Rhead
26909       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26910        END DO
26911        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26912        erdxj = scalar( erhead(1), dC_norm(1,j) )
26913        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
26914        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26915        facd1 = d1 * vbld_inv(i+nres)
26916        facd2 = d2 * vbld_inv(j)
26917        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
26918        DO k = 1, 3
26919       condor = (erhead_tail(k,2) &
26920        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
26921
26922       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26923       gradpepcatx(k,i) = gradpepcatx(k,i) &
26924               - dGCLdR * pom &
26925               - dPOLdR2 * (erhead_tail(k,2) &
26926        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
26927               - dGLJdR * pom
26928
26929       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
26930 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
26931 !                  + dGCLdR * pom &
26932 !                  + dPOLdR2 * condor &
26933 !                  + dGLJdR * pom
26934
26935
26936       gradpepcat(k,i) = gradpepcat(k,i) &
26937               - dGCLdR * erhead(k) &
26938               - dPOLdR2 * erhead_tail(k,2) &
26939               - dGLJdR * erhead(k)
26940
26941       gradpepcat(k,j) = gradpepcat(k,j) &
26942               + dGCLdR * erhead(k) &
26943               + dPOLdR2 * erhead_tail(k,2) &
26944               + dGLJdR * erhead(k)
26945
26946        END DO
26947        RETURN
26948       END SUBROUTINE edq_cat
26949
26950       SUBROUTINE edq_cat_pep(Ecl,Elj,Epol)
26951       use comm_momo
26952       use calc_data
26953
26954       double precision  facd3, adler,ecl,elj,epol
26955        alphapol2 = alphapolcat(itypj,itypi)
26956        w1        = wqdipcat(1,itypi,itypj)
26957        w2        = wqdipcat(2,itypi,itypj)
26958        pis       = sig0headcat(itypi,itypj)
26959        eps_head  = epsheadcat(itypi,itypj)
26960 !c!-------------------------------------------------------------------
26961 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26962        R2 = 0.0d0
26963        DO k = 1, 3
26964 !c! Calculate head-to-tail distances
26965       R2=R2+(chead(k,2)-ctail(k,1))**2
26966        END DO
26967 !c! Pitagoras
26968        R2 = dsqrt(R2)
26969
26970 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26971 !c!     &        +dhead(1,1,itypi,itypj))**2))
26972 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26973 !c!     &        +dhead(2,1,itypi,itypj))**2))
26974
26975
26976 !c!-------------------------------------------------------------------
26977 !c! ecl
26978        sparrow  = w1 * Qj * om1
26979        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
26980 !       print *,"CO2", itypi,itypj
26981 !       print *,"CO?!.", w1,w2,Qj,om1
26982        ECL = sparrow / Rhead**2.0d0 &
26983          - hawk    / Rhead**4.0d0
26984 !c!-------------------------------------------------------------------
26985 !c! derivative of ecl is Gcl
26986 !c! dF/dr part
26987        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26988              + 4.0d0 * hawk    / Rhead**5.0d0
26989 !c! dF/dom1
26990        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
26991 !c! dF/dom2
26992        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
26993 !c--------------------------------------------------------------------
26994 !c--------------------------------------------------------------------
26995 !c Polarization energy
26996 !c Epol
26997        MomoFac2 = (1.0d0 - chi2 * sqom1)
26998        RR2  = R2 * R2 / MomoFac2
26999        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27000        fgb2 = sqrt(RR2  + a12sq * ee2)
27001        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27002        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27003              / (fgb2 ** 5.0d0)
27004        dFGBdR2 = ( (R2 / MomoFac2)  &
27005              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27006              / (2.0d0 * fgb2)
27007        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27008             * (2.0d0 - 0.5d0 * ee2) ) &
27009             / (2.0d0 * fgb2)
27010        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27011 !c!       dPOLdR2 = 0.0d0
27012        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27013 !c!       dPOLdOM1 = 0.0d0
27014        dPOLdOM2 = 0.0d0
27015 !c!-------------------------------------------------------------------
27016 !c! Elj
27017        pom = (pis / Rhead)**6.0d0
27018        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27019 !c! derivative of Elj is Glj
27020        dGLJdR = 4.0d0 * eps_head &
27021          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27022          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27023 !c!-------------------------------------------------------------------
27024
27025 !c! Return the results
27026 !c! (see comments in Eqq)
27027        DO k = 1, 3
27028       erhead(k) = Rhead_distance(k)/Rhead
27029       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27030        END DO
27031        erdxi = scalar( erhead(1), dC_norm(1,i) )
27032        erdxj = scalar( erhead(1), dC_norm(1,j) )
27033        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27034        adler = scalar( erhead_tail(1,2), dC_norm(1,i) )
27035        facd1 = d1 * vbld_inv(i+1)/2.0
27036        facd2 = d2 * vbld_inv(j)
27037        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+1)/2.0
27038        DO k = 1, 3
27039       condor = (erhead_tail(k,2) &
27040        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27041
27042       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i))
27043 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
27044 !                  - dGCLdR * pom &
27045 !                  - dPOLdR2 * (erhead_tail(k,2) &
27046 !       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27047 !                  - dGLJdR * pom
27048
27049       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
27050 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
27051 !                  + dGCLdR * pom &
27052 !                  + dPOLdR2 * condor &
27053 !                  + dGLJdR * pom
27054
27055
27056       gradpepcat(k,i) = gradpepcat(k,i) +0.5d0*( &
27057               - dGCLdR * erhead(k) &
27058               - dPOLdR2 * erhead_tail(k,2) &
27059               - dGLJdR * erhead(k))
27060       gradpepcat(k,i+1) = gradpepcat(k,i+1) +0.5d0*( &
27061               - dGCLdR * erhead(k) &
27062               - dPOLdR2 * erhead_tail(k,2) &
27063               - dGLJdR * erhead(k))
27064
27065
27066       gradpepcat(k,j) = gradpepcat(k,j) &
27067               + dGCLdR * erhead(k) &
27068               + dPOLdR2 * erhead_tail(k,2) &
27069               + dGLJdR * erhead(k)
27070
27071        END DO
27072        RETURN
27073       END SUBROUTINE edq_cat_pep
27074
27075       SUBROUTINE edd(ECL)
27076 !       IMPLICIT NONE
27077        use comm_momo
27078       use calc_data
27079
27080        double precision ecl
27081 !c!       csig = sigiso(itypi,itypj)
27082        w1 = wqdip(1,itypi,itypj)
27083        w2 = wqdip(2,itypi,itypj)
27084 !c!-------------------------------------------------------------------
27085 !c! ECL
27086        fac = (om12 - 3.0d0 * om1 * om2)
27087        c1 = (w1 / (Rhead**3.0d0)) * fac
27088        c2 = (w2 / Rhead ** 6.0d0) &
27089         * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
27090        ECL = c1 - c2
27091 !c!       write (*,*) "w1 = ", w1
27092 !c!       write (*,*) "w2 = ", w2
27093 !c!       write (*,*) "om1 = ", om1
27094 !c!       write (*,*) "om2 = ", om2
27095 !c!       write (*,*) "om12 = ", om12
27096 !c!       write (*,*) "fac = ", fac
27097 !c!       write (*,*) "c1 = ", c1
27098 !c!       write (*,*) "c2 = ", c2
27099 !c!       write (*,*) "Ecl = ", Ecl
27100 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
27101 !c!       write (*,*) "c2_2 = ",
27102 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
27103 !c!-------------------------------------------------------------------
27104 !c! dervative of ECL is GCL...
27105 !c! dECL/dr
27106        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
27107        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
27108         * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
27109        dGCLdR = c1 - c2
27110 !c! dECL/dom1
27111        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
27112        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
27113         * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
27114        dGCLdOM1 = c1 - c2
27115 !c! dECL/dom2
27116        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
27117        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
27118         * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
27119        dGCLdOM2 = c1 - c2
27120 !c! dECL/dom12
27121        c1 = w1 / (Rhead ** 3.0d0)
27122        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
27123        dGCLdOM12 = c1 - c2
27124 !c!-------------------------------------------------------------------
27125 !c! Return the results
27126 !c! (see comments in Eqq)
27127        DO k= 1, 3
27128       erhead(k) = Rhead_distance(k)/Rhead
27129        END DO
27130        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27131        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27132        facd1 = d1 * vbld_inv(i+nres)
27133        facd2 = d2 * vbld_inv(j+nres)
27134        DO k = 1, 3
27135
27136       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27137       gvdwx(k,i) = gvdwx(k,i)    - dGCLdR * pom
27138       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27139       gvdwx(k,j) = gvdwx(k,j)    + dGCLdR * pom
27140
27141       gvdwc(k,i) = gvdwc(k,i)    - dGCLdR * erhead(k)
27142       gvdwc(k,j) = gvdwc(k,j)    + dGCLdR * erhead(k)
27143        END DO
27144        RETURN
27145       END SUBROUTINE edd
27146       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27147 !       IMPLICIT NONE
27148        use comm_momo
27149       use calc_data
27150
27151        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
27152        eps_out=80.0d0
27153        itypi = itype(i,1)
27154        itypj = itype(j,1)
27155 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
27156 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
27157 !c!       t_bath = 300
27158 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
27159        Rb=0.001986d0
27160        BetaT = 1.0d0 / (298.0d0 * Rb)
27161 !c! Gay-berne var's
27162        sig0ij = sigma( itypi,itypj )
27163        chi1   = chi( itypi, itypj )
27164        chi2   = chi( itypj, itypi )
27165        chi12  = chi1 * chi2
27166        chip1  = chipp( itypi, itypj )
27167        chip2  = chipp( itypj, itypi )
27168        chip12 = chip1 * chip2
27169 !       chi1=0.0
27170 !       chi2=0.0
27171 !       chi12=0.0
27172 !       chip1=0.0
27173 !       chip2=0.0
27174 !       chip12=0.0
27175 !c! not used by momo potential, but needed by sc_angular which is shared
27176 !c! by all energy_potential subroutines
27177        alf1   = 0.0d0
27178        alf2   = 0.0d0
27179        alf12  = 0.0d0
27180 !c! location, location, location
27181 !       xj  = c( 1, nres+j ) - xi
27182 !       yj  = c( 2, nres+j ) - yi
27183 !       zj  = c( 3, nres+j ) - zi
27184        dxj = dc_norm( 1, nres+j )
27185        dyj = dc_norm( 2, nres+j )
27186        dzj = dc_norm( 3, nres+j )
27187 !c! distance from center of chain(?) to polar/charged head
27188 !c!       write (*,*) "istate = ", 1
27189 !c!       write (*,*) "ii = ", 1
27190 !c!       write (*,*) "jj = ", 1
27191        d1 = dhead(1, 1, itypi, itypj)
27192        d2 = dhead(2, 1, itypi, itypj)
27193 !c! ai*aj from Fgb
27194        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
27195 !c!       a12sq = a12sq * a12sq
27196 !c! charge of amino acid itypi is...
27197        Qi  = icharge(itypi)
27198        Qj  = icharge(itypj)
27199        Qij = Qi * Qj
27200 !c! chis1,2,12
27201        chis1 = chis(itypi,itypj)
27202        chis2 = chis(itypj,itypi)
27203        chis12 = chis1 * chis2
27204        sig1 = sigmap1(itypi,itypj)
27205        sig2 = sigmap2(itypi,itypj)
27206 !c!       write (*,*) "sig1 = ", sig1
27207 !c!       write (*,*) "sig2 = ", sig2
27208 !c! alpha factors from Fcav/Gcav
27209        b1cav = alphasur(1,itypi,itypj)
27210 !       b1cav=0.0
27211        b2cav = alphasur(2,itypi,itypj)
27212        b3cav = alphasur(3,itypi,itypj)
27213        b4cav = alphasur(4,itypi,itypj)
27214        wqd = wquad(itypi, itypj)
27215 !c! used by Fgb
27216        eps_in = epsintab(itypi,itypj)
27217        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
27218 !c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
27219 !c!-------------------------------------------------------------------
27220 !c! tail location and distance calculations
27221        Rtail = 0.0d0
27222        DO k = 1, 3
27223       ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
27224       ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
27225        END DO
27226 !c! tail distances will be themselves usefull elswhere
27227 !c1 (in Gcav, for example)
27228        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
27229        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
27230        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
27231        Rtail = dsqrt(  &
27232         (Rtail_distance(1)*Rtail_distance(1))  &
27233       + (Rtail_distance(2)*Rtail_distance(2))  &
27234       + (Rtail_distance(3)*Rtail_distance(3)))
27235 !c!-------------------------------------------------------------------
27236 !c! Calculate location and distance between polar heads
27237 !c! distance between heads
27238 !c! for each one of our three dimensional space...
27239        d1 = dhead(1, 1, itypi, itypj)
27240        d2 = dhead(2, 1, itypi, itypj)
27241
27242        DO k = 1,3
27243 !c! location of polar head is computed by taking hydrophobic centre
27244 !c! and moving by a d1 * dc_norm vector
27245 !c! see unres publications for very informative images
27246       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27247       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
27248 !c! distance
27249 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27250 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27251       Rhead_distance(k) = chead(k,2) - chead(k,1)
27252        END DO
27253 !c! pitagoras (root of sum of squares)
27254        Rhead = dsqrt(   &
27255         (Rhead_distance(1)*Rhead_distance(1)) &
27256       + (Rhead_distance(2)*Rhead_distance(2)) &
27257       + (Rhead_distance(3)*Rhead_distance(3)))
27258 !c!-------------------------------------------------------------------
27259 !c! zero everything that should be zero'ed
27260        Egb = 0.0d0
27261        ECL = 0.0d0
27262        Elj = 0.0d0
27263        Equad = 0.0d0
27264        Epol = 0.0d0
27265        eheadtail = 0.0d0
27266        dGCLdOM1 = 0.0d0
27267        dGCLdOM2 = 0.0d0
27268        dGCLdOM12 = 0.0d0
27269        dPOLdOM1 = 0.0d0
27270        dPOLdOM2 = 0.0d0
27271        RETURN
27272       END SUBROUTINE elgrad_init
27273
27274
27275       SUBROUTINE elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27276       use comm_momo
27277       use calc_data
27278        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
27279        eps_out=80.0d0
27280        itypi = itype(i,1)
27281        itypj = itype(j,5)
27282 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
27283 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
27284 !c!       t_bath = 300
27285 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
27286        Rb=0.001986d0
27287        BetaT = 1.0d0 / (298.0d0 * Rb)
27288 !c! Gay-berne var's
27289        sig0ij = sigmacat( itypi,itypj )
27290        chi1   = chi1cat( itypi, itypj )
27291        chi2   = 0.0d0
27292        chi12  = 0.0d0
27293        chip1  = chipp1cat( itypi, itypj )
27294        chip2  = 0.0d0
27295        chip12 = 0.0d0
27296 !c! not used by momo potential, but needed by sc_angular which is shared
27297 !c! by all energy_potential subroutines
27298        alf1   = 0.0d0
27299        alf2   = 0.0d0
27300        alf12  = 0.0d0
27301        dxj = dc_norm( 1, nres+j )
27302        dyj = dc_norm( 2, nres+j )
27303        dzj = dc_norm( 3, nres+j )
27304 !c! distance from center of chain(?) to polar/charged head
27305        d1 = dheadcat(1, 1, itypi, itypj)
27306        d2 = dheadcat(2, 1, itypi, itypj)
27307 !c! ai*aj from Fgb
27308        a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj)
27309 !c!       a12sq = a12sq * a12sq
27310 !c! charge of amino acid itypi is...
27311        Qi  = icharge(itypi)
27312        Qj  = ichargecat(itypj)
27313        Qij = Qi * Qj
27314 !c! chis1,2,12
27315        chis1 = chis1cat(itypi,itypj)
27316        chis2 = 0.0d0
27317        chis12 = 0.0d0
27318        sig1 = sigmap1cat(itypi,itypj)
27319        sig2 = sigmap2cat(itypi,itypj)
27320 !c! alpha factors from Fcav/Gcav
27321        b1cav = alphasurcat(1,itypi,itypj)
27322        b2cav = alphasurcat(2,itypi,itypj)
27323        b3cav = alphasurcat(3,itypi,itypj)
27324        b4cav = alphasurcat(4,itypi,itypj)
27325        wqd = wquadcat(itypi, itypj)
27326 !c! used by Fgb
27327        eps_in = epsintabcat(itypi,itypj)
27328        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
27329 !c!-------------------------------------------------------------------
27330 !c! tail location and distance calculations
27331        Rtail = 0.0d0
27332        DO k = 1, 3
27333       ctail(k,1)=c(k,i+nres)-dtailcat(1,itypi,itypj)*dc_norm(k,nres+i)
27334       ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
27335        END DO
27336 !c! tail distances will be themselves usefull elswhere
27337 !c1 (in Gcav, for example)
27338        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
27339        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
27340        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
27341        Rtail = dsqrt(  &
27342         (Rtail_distance(1)*Rtail_distance(1))  &
27343       + (Rtail_distance(2)*Rtail_distance(2))  &
27344       + (Rtail_distance(3)*Rtail_distance(3)))
27345 !c!-------------------------------------------------------------------
27346 !c! Calculate location and distance between polar heads
27347 !c! distance between heads
27348 !c! for each one of our three dimensional space...
27349        d1 = dheadcat(1, 1, itypi, itypj)
27350        d2 = dheadcat(2, 1, itypi, itypj)
27351
27352        DO k = 1,3
27353 !c! location of polar head is computed by taking hydrophobic centre
27354 !c! and moving by a d1 * dc_norm vector
27355 !c! see unres publications for very informative images
27356       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27357       chead(k,2) = c(k, j)
27358 !c! distance
27359 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27360 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27361       Rhead_distance(k) = chead(k,2) - chead(k,1)
27362        END DO
27363 !c! pitagoras (root of sum of squares)
27364        Rhead = dsqrt(   &
27365         (Rhead_distance(1)*Rhead_distance(1)) &
27366       + (Rhead_distance(2)*Rhead_distance(2)) &
27367       + (Rhead_distance(3)*Rhead_distance(3)))
27368 !c!-------------------------------------------------------------------
27369 !c! zero everything that should be zero'ed
27370        Egb = 0.0d0
27371        ECL = 0.0d0
27372        Elj = 0.0d0
27373        Equad = 0.0d0
27374        Epol = 0.0d0
27375        eheadtail = 0.0d0
27376        dGCLdOM1 = 0.0d0
27377        dGCLdOM2 = 0.0d0
27378        dGCLdOM12 = 0.0d0
27379        dPOLdOM1 = 0.0d0
27380        dPOLdOM2 = 0.0d0
27381        RETURN
27382       END SUBROUTINE elgrad_init_cat
27383
27384       SUBROUTINE elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27385       use comm_momo
27386       use calc_data
27387        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
27388        eps_out=80.0d0
27389        itypi = 10
27390        itypj = itype(j,5)
27391 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
27392 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
27393 !c!       t_bath = 300
27394 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
27395        Rb=0.001986d0
27396        BetaT = 1.0d0 / (298.0d0 * Rb)
27397 !c! Gay-berne var's
27398        sig0ij = sigmacat( itypi,itypj )
27399        chi1   = chi1cat( itypi, itypj )
27400        chi2   = 0.0d0
27401        chi12  = 0.0d0
27402        chip1  = chipp1cat( itypi, itypj )
27403        chip2  = 0.0d0
27404        chip12 = 0.0d0
27405 !c! not used by momo potential, but needed by sc_angular which is shared
27406 !c! by all energy_potential subroutines
27407        alf1   = 0.0d0
27408        alf2   = 0.0d0
27409        alf12  = 0.0d0
27410        dxj = 0.0d0 !dc_norm( 1, nres+j )
27411        dyj = 0.0d0 !dc_norm( 2, nres+j )
27412        dzj = 0.0d0 !dc_norm( 3, nres+j )
27413 !c! distance from center of chain(?) to polar/charged head
27414        d1 = dheadcat(1, 1, itypi, itypj)
27415        d2 = dheadcat(2, 1, itypi, itypj)
27416 !c! ai*aj from Fgb
27417        a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj)
27418 !c!       a12sq = a12sq * a12sq
27419 !c! charge of amino acid itypi is...
27420        Qi  = 0
27421        Qj  = ichargecat(itypj)
27422 !       Qij = Qi * Qj
27423 !c! chis1,2,12
27424        chis1 = chis1cat(itypi,itypj)
27425        chis2 = 0.0d0
27426        chis12 = 0.0d0
27427        sig1 = sigmap1cat(itypi,itypj)
27428        sig2 = sigmap2cat(itypi,itypj)
27429 !c! alpha factors from Fcav/Gcav
27430        b1cav = alphasurcat(1,itypi,itypj)
27431        b2cav = alphasurcat(2,itypi,itypj)
27432        b3cav = alphasurcat(3,itypi,itypj)
27433        b4cav = alphasurcat(4,itypi,itypj)
27434        wqd = wquadcat(itypi, itypj)
27435 !c! used by Fgb
27436        eps_in = epsintabcat(itypi,itypj)
27437        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
27438 !c!-------------------------------------------------------------------
27439 !c! tail location and distance calculations
27440        Rtail = 0.0d0
27441        DO k = 1, 3
27442       ctail(k,1)=(c(k,i)+c(k,i+1))/2.0-dtailcat(1,itypi,itypj)*dc_norm(k,i)
27443       ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
27444        END DO
27445 !c! tail distances will be themselves usefull elswhere
27446 !c1 (in Gcav, for example)
27447        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
27448        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
27449        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
27450        Rtail = dsqrt(  &
27451         (Rtail_distance(1)*Rtail_distance(1))  &
27452       + (Rtail_distance(2)*Rtail_distance(2))  &
27453       + (Rtail_distance(3)*Rtail_distance(3)))
27454 !c!-------------------------------------------------------------------
27455 !c! Calculate location and distance between polar heads
27456 !c! distance between heads
27457 !c! for each one of our three dimensional space...
27458        d1 = dheadcat(1, 1, itypi, itypj)
27459        d2 = dheadcat(2, 1, itypi, itypj)
27460
27461        DO k = 1,3
27462 !c! location of polar head is computed by taking hydrophobic centre
27463 !c! and moving by a d1 * dc_norm vector
27464 !c! see unres publications for very informative images
27465       chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
27466       chead(k,2) = c(k, j)
27467 !c! distance
27468 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27469 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27470       Rhead_distance(k) = chead(k,2) - chead(k,1)
27471        END DO
27472 !c! pitagoras (root of sum of squares)
27473        Rhead = dsqrt(   &
27474         (Rhead_distance(1)*Rhead_distance(1)) &
27475       + (Rhead_distance(2)*Rhead_distance(2)) &
27476       + (Rhead_distance(3)*Rhead_distance(3)))
27477 !c!-------------------------------------------------------------------
27478 !c! zero everything that should be zero'ed
27479        Egb = 0.0d0
27480        ECL = 0.0d0
27481        Elj = 0.0d0
27482        Equad = 0.0d0
27483        Epol = 0.0d0
27484        eheadtail = 0.0d0
27485        dGCLdOM1 = 0.0d0
27486        dGCLdOM2 = 0.0d0
27487        dGCLdOM12 = 0.0d0
27488        dPOLdOM1 = 0.0d0
27489        dPOLdOM2 = 0.0d0
27490        RETURN
27491       END SUBROUTINE elgrad_init_cat_pep
27492
27493       double precision function tschebyshev(m,n,x,y)
27494       implicit none
27495       integer i,m,n
27496       double precision x(n),y,yy(0:maxvar),aux
27497 !c Tschebyshev polynomial. Note that the first term is omitted
27498 !c m=0: the constant term is included
27499 !c m=1: the constant term is not included
27500       yy(0)=1.0d0
27501       yy(1)=y
27502       do i=2,n
27503       yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
27504       enddo
27505       aux=0.0d0
27506       do i=m,n
27507       aux=aux+x(i)*yy(i)
27508       enddo
27509       tschebyshev=aux
27510       return
27511       end function tschebyshev
27512 !C--------------------------------------------------------------------------
27513       double precision function gradtschebyshev(m,n,x,y)
27514       implicit none
27515       integer i,m,n
27516       double precision x(n+1),y,yy(0:maxvar),aux
27517 !c Tschebyshev polynomial. Note that the first term is omitted
27518 !c m=0: the constant term is included
27519 !c m=1: the constant term is not included
27520       yy(0)=1.0d0
27521       yy(1)=2.0d0*y
27522       do i=2,n
27523       yy(i)=2*y*yy(i-1)-yy(i-2)
27524       enddo
27525       aux=0.0d0
27526       do i=m,n
27527       aux=aux+x(i+1)*yy(i)*(i+1)
27528 !C        print *, x(i+1),yy(i),i
27529       enddo
27530       gradtschebyshev=aux
27531       return
27532       end function gradtschebyshev
27533
27534       subroutine make_SCSC_inter_list
27535       include 'mpif.h'
27536       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
27537       real*8 :: dist_init, dist_temp,r_buff_list
27538       integer:: contlisti(250*nres),contlistj(250*nres)
27539 !      integer :: newcontlisti(200*nres),newcontlistj(200*nres)
27540       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_sc,g_ilist_sc
27541       integer displ(0:nprocs),i_ilist_sc(0:nprocs),ierr
27542 !            print *,"START make_SC"
27543         r_buff_list=5.0
27544           ilist_sc=0
27545           do i=iatsc_s,iatsc_e
27546            itypi=iabs(itype(i,1))
27547            if (itypi.eq.ntyp1) cycle
27548            xi=c(1,nres+i)
27549            yi=c(2,nres+i)
27550            zi=c(3,nres+i)
27551           call to_box(xi,yi,zi)
27552            do iint=1,nint_gr(i)
27553             do j=istart(i,iint),iend(i,iint)
27554              itypj=iabs(itype(j,1))
27555              if (itypj.eq.ntyp1) cycle
27556              xj=c(1,nres+j)
27557              yj=c(2,nres+j)
27558              zj=c(3,nres+j)
27559              call to_box(xj,yj,zj)
27560 !          call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
27561 !          faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
27562           xj=boxshift(xj-xi,boxxsize)
27563           yj=boxshift(yj-yi,boxysize)
27564           zj=boxshift(zj-zi,boxzsize)
27565           dist_init=xj**2+yj**2+zj**2
27566 !             dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
27567 ! r_buff_list is a read value for a buffer
27568              if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
27569 ! Here the list is created
27570              ilist_sc=ilist_sc+1
27571 ! this can be substituted by cantor and anti-cantor
27572              contlisti(ilist_sc)=i
27573              contlistj(ilist_sc)=j
27574
27575              endif
27576            enddo
27577            enddo
27578            enddo
27579 !         call MPI_Reduce(ilist_sc,g_ilist_sc,1,&
27580 !          MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
27581 !        call MPI_Gather(newnss,1,MPI_INTEGER,&
27582 !                        i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
27583 #ifdef DEBUG
27584       write (iout,*) "before MPIREDUCE",ilist_sc
27585       do i=1,ilist_sc
27586       write (iout,*) i,contlisti(i),contlistj(i)
27587       enddo
27588 #endif
27589       if (nfgtasks.gt.1)then
27590
27591       call MPI_Reduce(ilist_sc,g_ilist_sc,1,&
27592         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
27593 !        write(iout,*) "before bcast",g_ilist_sc
27594       call MPI_Gather(ilist_sc,1,MPI_INTEGER,&
27595                   i_ilist_sc,1,MPI_INTEGER,king,FG_COMM,IERR)
27596       displ(0)=0
27597       do i=1,nfgtasks-1,1
27598         displ(i)=i_ilist_sc(i-1)+displ(i-1)
27599       enddo
27600 !        write(iout,*) "before gather",displ(0),displ(1)
27601       call MPI_Gatherv(contlisti,ilist_sc,MPI_INTEGER,&
27602                    newcontlisti,i_ilist_sc,displ,MPI_INTEGER,&
27603                    king,FG_COMM,IERR)
27604       call MPI_Gatherv(contlistj,ilist_sc,MPI_INTEGER,&
27605                    newcontlistj,i_ilist_sc,displ,MPI_INTEGER,&
27606                    king,FG_COMM,IERR)
27607       call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM,IERR)
27608 !        write(iout,*) "before bcast",g_ilist_sc
27609 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27610       call MPI_Bcast(newcontlisti,g_ilist_sc,MPI_INT,king,FG_COMM,IERR)
27611       call MPI_Bcast(newcontlistj,g_ilist_sc,MPI_INT,king,FG_COMM,IERR)
27612
27613 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27614
27615       else
27616       g_ilist_sc=ilist_sc
27617
27618       do i=1,ilist_sc
27619       newcontlisti(i)=contlisti(i)
27620       newcontlistj(i)=contlistj(i)
27621       enddo
27622       endif
27623
27624 #ifdef DEBUG
27625       write (iout,*) "after MPIREDUCE",g_ilist_sc
27626       do i=1,g_ilist_sc
27627       write (iout,*) i,newcontlisti(i),newcontlistj(i)
27628       enddo
27629 #endif
27630       call int_bounds(g_ilist_sc,g_listscsc_start,g_listscsc_end)
27631       return
27632       end subroutine make_SCSC_inter_list
27633 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
27634
27635       subroutine make_SCp_inter_list
27636       use MD_data,  only: itime_mat
27637
27638       include 'mpif.h'
27639       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
27640       real*8 :: dist_init, dist_temp,r_buff_list
27641       integer:: contlistscpi(250*nres),contlistscpj(250*nres)
27642 !      integer :: newcontlistscpi(200*nres),newcontlistscpj(200*nres)
27643       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_scp,g_ilist_scp
27644       integer displ(0:nprocs),i_ilist_scp(0:nprocs),ierr
27645 !            print *,"START make_SC"
27646       r_buff_list=5.0
27647           ilist_scp=0
27648       do i=iatscp_s,iatscp_e
27649       if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
27650       xi=0.5D0*(c(1,i)+c(1,i+1))
27651       yi=0.5D0*(c(2,i)+c(2,i+1))
27652       zi=0.5D0*(c(3,i)+c(3,i+1))
27653         call to_box(xi,yi,zi)
27654       do iint=1,nscp_gr(i)
27655
27656       do j=iscpstart(i,iint),iscpend(i,iint)
27657         itypj=iabs(itype(j,1))
27658         if (itypj.eq.ntyp1) cycle
27659 ! Uncomment following three lines for SC-p interactions
27660 !         xj=c(1,nres+j)-xi
27661 !         yj=c(2,nres+j)-yi
27662 !         zj=c(3,nres+j)-zi
27663 ! Uncomment following three lines for Ca-p interactions
27664 !          xj=c(1,j)-xi
27665 !          yj=c(2,j)-yi
27666 !          zj=c(3,j)-zi
27667         xj=c(1,j)
27668         yj=c(2,j)
27669         zj=c(3,j)
27670         call to_box(xj,yj,zj)
27671       xj=boxshift(xj-xi,boxxsize)
27672       yj=boxshift(yj-yi,boxysize)
27673       zj=boxshift(zj-zi,boxzsize)
27674       dist_init=xj**2+yj**2+zj**2
27675 #ifdef DEBUG
27676             ! r_buff_list is a read value for a buffer
27677              if ((sqrt(dist_init).le.(r_cut_ele)).and.(ifirstrun.eq.0)) then
27678 ! Here the list is created
27679              ilist_scp_first=ilist_scp_first+1
27680 ! this can be substituted by cantor and anti-cantor
27681              contlistscpi_f(ilist_scp_first)=i
27682              contlistscpj_f(ilist_scp_first)=j
27683             endif
27684 #endif
27685 ! r_buff_list is a read value for a buffer
27686              if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
27687 ! Here the list is created
27688              ilist_scp=ilist_scp+1
27689 ! this can be substituted by cantor and anti-cantor
27690              contlistscpi(ilist_scp)=i
27691              contlistscpj(ilist_scp)=j
27692             endif
27693            enddo
27694            enddo
27695            enddo
27696 #ifdef DEBUG
27697       write (iout,*) "before MPIREDUCE",ilist_scp
27698       do i=1,ilist_scp
27699       write (iout,*) i,contlistscpi(i),contlistscpj(i)
27700       enddo
27701 #endif
27702       if (nfgtasks.gt.1)then
27703
27704       call MPI_Reduce(ilist_scp,g_ilist_scp,1,&
27705         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
27706 !        write(iout,*) "before bcast",g_ilist_sc
27707       call MPI_Gather(ilist_scp,1,MPI_INTEGER,&
27708                   i_ilist_scp,1,MPI_INTEGER,king,FG_COMM,IERR)
27709       displ(0)=0
27710       do i=1,nfgtasks-1,1
27711         displ(i)=i_ilist_scp(i-1)+displ(i-1)
27712       enddo
27713 !        write(iout,*) "before gather",displ(0),displ(1)
27714       call MPI_Gatherv(contlistscpi,ilist_scp,MPI_INTEGER,&
27715                    newcontlistscpi,i_ilist_scp,displ,MPI_INTEGER,&
27716                    king,FG_COMM,IERR)
27717       call MPI_Gatherv(contlistscpj,ilist_scp,MPI_INTEGER,&
27718                    newcontlistscpj,i_ilist_scp,displ,MPI_INTEGER,&
27719                    king,FG_COMM,IERR)
27720       call MPI_Bcast(g_ilist_scp,1,MPI_INT,king,FG_COMM,IERR)
27721 !        write(iout,*) "before bcast",g_ilist_sc
27722 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27723       call MPI_Bcast(newcontlistscpi,g_ilist_scp,MPI_INT,king,FG_COMM,IERR)
27724       call MPI_Bcast(newcontlistscpj,g_ilist_scp,MPI_INT,king,FG_COMM,IERR)
27725
27726 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27727
27728       else
27729       g_ilist_scp=ilist_scp
27730
27731       do i=1,ilist_scp
27732       newcontlistscpi(i)=contlistscpi(i)
27733       newcontlistscpj(i)=contlistscpj(i)
27734       enddo
27735       endif
27736
27737 #ifdef DEBUG
27738       write (iout,*) "after MPIREDUCE",g_ilist_scp
27739       do i=1,g_ilist_scp
27740       write (iout,*) i,newcontlistscpi(i),newcontlistscpj(i)
27741       enddo
27742
27743 !      if (ifirstrun.eq.0) ifirstrun=1
27744 !      do i=1,ilist_scp_first
27745 !       do j=1,g_ilist_scp
27746 !        if ((newcontlistscpi(j).eq.contlistscpi_f(i)).and.&
27747 !         (newcontlistscpj(j).eq.contlistscpj_f(i))) go to 126
27748 !        enddo
27749 !       print *,itime_mat,"ERROR matrix needs updating"
27750 !       print *,contlistscpi_f(i),contlistscpj_f(i)
27751 !  126  continue
27752 !      enddo
27753 #endif
27754       call int_bounds(g_ilist_scp,g_listscp_start,g_listscp_end)
27755
27756       return
27757       end subroutine make_SCp_inter_list
27758
27759 !-----------------------------------------------------------------------------
27760 !-----------------------------------------------------------------------------
27761
27762
27763       subroutine make_pp_inter_list
27764       include 'mpif.h'
27765       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
27766       real*8 :: xmedj,ymedj,zmedj,sslipi,ssgradlipi,faclipij2,sslipj,ssgradlipj
27767       real*8 :: dist_init, dist_temp,r_buff_list,dxi,dyi,dzi,xmedi,ymedi,zmedi
27768       real*8 :: dx_normi,dy_normi,dz_normi,dxj,dyj,dzj,dx_normj,dy_normj,dz_normj
27769       integer:: contlistppi(250*nres),contlistppj(250*nres)
27770 !      integer :: newcontlistppi(200*nres),newcontlistppj(200*nres)
27771       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_pp,g_ilist_pp
27772       integer displ(0:nprocs),i_ilist_pp(0:nprocs),ierr
27773 !            write(iout,*),"START make_pp",iatel_s,iatel_e,r_cut_ele+r_buff_list
27774             ilist_pp=0
27775       r_buff_list=5.0
27776       do i=iatel_s,iatel_e
27777         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
27778         dxi=dc(1,i)
27779         dyi=dc(2,i)
27780         dzi=dc(3,i)
27781         dx_normi=dc_norm(1,i)
27782         dy_normi=dc_norm(2,i)
27783         dz_normi=dc_norm(3,i)
27784         xmedi=c(1,i)+0.5d0*dxi
27785         ymedi=c(2,i)+0.5d0*dyi
27786         zmedi=c(3,i)+0.5d0*dzi
27787
27788         call to_box(xmedi,ymedi,zmedi)
27789         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
27790 !          write (iout,*) i,j,itype(i,1),itype(j,1)
27791 !          if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
27792
27793 ! 1,j)
27794              do j=ielstart(i),ielend(i)
27795 !          write (iout,*) i,j,itype(i,1),itype(j,1)
27796           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
27797           dxj=dc(1,j)
27798           dyj=dc(2,j)
27799           dzj=dc(3,j)
27800           dx_normj=dc_norm(1,j)
27801           dy_normj=dc_norm(2,j)
27802           dz_normj=dc_norm(3,j)
27803 !          xj=c(1,j)+0.5D0*dxj-xmedi
27804 !          yj=c(2,j)+0.5D0*dyj-ymedi
27805 !          zj=c(3,j)+0.5D0*dzj-zmedi
27806           xj=c(1,j)+0.5D0*dxj
27807           yj=c(2,j)+0.5D0*dyj
27808           zj=c(3,j)+0.5D0*dzj
27809           call to_box(xj,yj,zj)
27810 !          call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
27811 !          faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
27812           xj=boxshift(xj-xmedi,boxxsize)
27813           yj=boxshift(yj-ymedi,boxysize)
27814           zj=boxshift(zj-zmedi,boxzsize)
27815           dist_init=xj**2+yj**2+zj**2
27816       if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
27817 ! Here the list is created
27818                  ilist_pp=ilist_pp+1
27819 ! this can be substituted by cantor and anti-cantor
27820                  contlistppi(ilist_pp)=i
27821                  contlistppj(ilist_pp)=j
27822               endif
27823 !             enddo
27824              enddo
27825              enddo
27826 #ifdef DEBUG
27827       write (iout,*) "before MPIREDUCE",ilist_pp
27828       do i=1,ilist_pp
27829       write (iout,*) i,contlistppi(i),contlistppj(i)
27830       enddo
27831 #endif
27832       if (nfgtasks.gt.1)then
27833
27834         call MPI_Reduce(ilist_pp,g_ilist_pp,1,&
27835           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
27836 !        write(iout,*) "before bcast",g_ilist_sc
27837         call MPI_Gather(ilist_pp,1,MPI_INTEGER,&
27838                         i_ilist_pp,1,MPI_INTEGER,king,FG_COMM,IERR)
27839         displ(0)=0
27840         do i=1,nfgtasks-1,1
27841           displ(i)=i_ilist_pp(i-1)+displ(i-1)
27842         enddo
27843 !        write(iout,*) "before gather",displ(0),displ(1)
27844         call MPI_Gatherv(contlistppi,ilist_pp,MPI_INTEGER,&
27845                          newcontlistppi,i_ilist_pp,displ,MPI_INTEGER,&
27846                          king,FG_COMM,IERR)
27847         call MPI_Gatherv(contlistppj,ilist_pp,MPI_INTEGER,&
27848                          newcontlistppj,i_ilist_pp,displ,MPI_INTEGER,&
27849                          king,FG_COMM,IERR)
27850         call MPI_Bcast(g_ilist_pp,1,MPI_INT,king,FG_COMM,IERR)
27851 !        write(iout,*) "before bcast",g_ilist_sc
27852 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27853         call MPI_Bcast(newcontlistppi,g_ilist_pp,MPI_INT,king,FG_COMM,IERR)
27854         call MPI_Bcast(newcontlistppj,g_ilist_pp,MPI_INT,king,FG_COMM,IERR)
27855
27856 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27857
27858         else
27859         g_ilist_pp=ilist_pp
27860
27861         do i=1,ilist_pp
27862         newcontlistppi(i)=contlistppi(i)
27863         newcontlistppj(i)=contlistppj(i)
27864         enddo
27865         endif
27866         call int_bounds(g_ilist_pp,g_listpp_start,g_listpp_end)
27867 #ifdef DEBUG
27868       write (iout,*) "after MPIREDUCE",g_ilist_pp
27869       do i=1,g_ilist_pp
27870       write (iout,*) i,newcontlistppi(i),newcontlistppj(i)
27871       enddo
27872 #endif
27873       return
27874       end subroutine make_pp_inter_list
27875
27876 !-----------------------------------------------------------------------------
27877       double precision function boxshift(x,boxsize)
27878       implicit none
27879       double precision x,boxsize
27880       double precision xtemp
27881       xtemp=dmod(x,boxsize)
27882       if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
27883         boxshift=xtemp-boxsize
27884       else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
27885         boxshift=xtemp+boxsize
27886       else
27887         boxshift=xtemp
27888       endif
27889       return
27890       end function boxshift
27891 !-----------------------------------------------------------------------------
27892       subroutine to_box(xi,yi,zi)
27893       implicit none
27894 !      include 'DIMENSIONS'
27895 !      include 'COMMON.CHAIN'
27896       double precision xi,yi,zi
27897       xi=dmod(xi,boxxsize)
27898       if (xi.lt.0.0d0) xi=xi+boxxsize
27899       yi=dmod(yi,boxysize)
27900       if (yi.lt.0.0d0) yi=yi+boxysize
27901       zi=dmod(zi,boxzsize)
27902       if (zi.lt.0.0d0) zi=zi+boxzsize
27903       return
27904       end subroutine to_box
27905 !--------------------------------------------------------------------------
27906       subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
27907       implicit none
27908 !      include 'DIMENSIONS'
27909 !      include 'COMMON.IOUNITS'
27910 !      include 'COMMON.CHAIN'
27911       double precision xi,yi,zi,sslipi,ssgradlipi
27912       double precision fracinbuf
27913 !      double precision sscalelip,sscagradlip
27914 #ifdef DEBUG
27915       write (iout,*) "bordlipbot",bordlipbot," bordliptop",bordliptop
27916       write (iout,*) "buflipbot",buflipbot," lipbufthick",lipbufthick
27917       write (iout,*) "xi yi zi",xi,yi,zi
27918 #endif
27919       if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
27920 ! the energy transfer exist
27921         if (zi.lt.buflipbot) then
27922 ! what fraction I am in
27923           fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
27924 ! lipbufthick is thickenes of lipid buffore
27925           sslipi=sscalelip(fracinbuf)
27926           ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
27927         elseif (zi.gt.bufliptop) then
27928           fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
27929           sslipi=sscalelip(fracinbuf)
27930           ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
27931         else
27932           sslipi=1.0d0
27933           ssgradlipi=0.0
27934         endif
27935       else
27936         sslipi=0.0d0
27937         ssgradlipi=0.0
27938       endif
27939 #ifdef DEBUG
27940       write (iout,*) "sslipi",sslipi," ssgradlipi",ssgradlipi
27941 #endif
27942       return
27943       end subroutine lipid_layer
27944
27945 !--------------------------------------------------------------------------
27946 !--------------------------------------------------------------------------
27947       end module energy