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,ehomology_constr
 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 !       print *,"wstrain check", wstrain
 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       if (constr_homology.ge.1) then
 747         call e_modeller(ehomology_constr)
 748 !        print *,'iset=',iset,'me=',me,ehomology_constr,
 749 !     &  'Processor',fg_rank,' CG group',kolor,
 750 !     &  ' absolute rank',MyRank
 751 !       print *,"tu"
 752       else
 753         ehomology_constr=0.0d0
 754       endif
 755
 756 !
 757 ! 6/23/01 Calculate double-torsional energy
 758 !
 759 !elwrite(iout,*) "in etotal",ipot
 760       if (wtor_d.gt.0) then
 761        call etor_d(etors_d)
 762       else
 763        etors_d=0
 764       endif
 765 !      print *,"Processor",myrank," computed Utord"
 766 !
 767 ! 21/5/07 Calculate local sicdechain correlation energy
 768 !
 769       if (wsccor.gt.0.0d0) then
 770         call eback_sc_corr(esccor)
 771       else
 772         esccor=0.0d0
 773       endif
 774
 775 !      write(iout,*) "before multibody"
 776       call flush(iout)
 777 !      print *,"Processor",myrank," computed Usccorr"
 778 !
 779 ! 12/1/95 Multi-body terms
 780 !
 781       n_corr=0
 782       n_corr1=0
 783       call flush(iout)
 784       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 785           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 786          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 787 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 788 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 789       else
 790          ecorr=0.0d0
 791          ecorr5=0.0d0
 792          ecorr6=0.0d0
 793          eturn6=0.0d0
 794       endif
 795 !elwrite(iout,*) "in etotal",ipot
 796       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 797          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 798 !d         write (iout,*) "multibody_hb ecorr",ecorr
 799       endif
 800 !      write(iout,*) "afeter  multibody hb"
 801
 802 !      print *,"Processor",myrank," computed Ucorr"
 803 !
 804 ! If performing constraint dynamics, call the constraint energy
 805 !  after the equilibration time
 806       if((usampl).and.(totT.gt.eq_time)) then
 807         write(iout,*) "usampl",usampl
 808          call EconstrQ
 809 !elwrite(iout,*) "afeter  multibody hb"
 810          call Econstr_back
 811 !elwrite(iout,*) "afeter  multibody hb"
 812       else
 813          Uconst=0.0d0
 814          Uconst_back=0.0d0
 815       endif
 816       call flush(iout)
 817 !         write(iout,*) "after Econstr"
 818
 819       if (wliptran.gt.0) then
 820 !        print *,"PRZED WYWOLANIEM"
 821         call Eliptransfer(eliptran)
 822       else
 823        eliptran=0.0d0
 824       endif
 825       if (fg_rank.eq.0) then
 826       if (AFMlog.gt.0) then
 827         call AFMforce(Eafmforce)
 828       else if (selfguide.gt.0) then
 829         call AFMvel(Eafmforce)
 830       else
 831         Eafmforce=0.0d0
 832       endif
 833       endif
 834       if (tubemode.eq.1) then
 835        call calctube(etube)
 836       else if (tubemode.eq.2) then
 837        call calctube2(etube)
 838       elseif (tubemode.eq.3) then
 839        call calcnano(etube)
 840       else
 841        etube=0.0d0
 842       endif
 843 !--------------------------------------------------------
 844 !       write (iout,*) "NRES_MOLEC(2),",nres_molec(2)
 845 !      print *,"before",ees,evdw1,ecorr
 846 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 847       if (nres_molec(2).gt.0) then
 848       call ebond_nucl(estr_nucl)
 849       call ebend_nucl(ebe_nucl)
 850       call etor_nucl(etors_nucl)
 851       call esb_gb(evdwsb,eelsb)
 852       call epp_nucl_sub(evdwpp,eespp)
 853       call epsb(evdwpsb,eelpsb)
 854       call esb(esbloc)
 855       call multibody_hb_nucl(ecorr_nucl,ecorr3_nucl,n_corr,n_corr1)
 856             call ecat_nucl(ecation_nucl)
 857       else
 858        etors_nucl=0.0d0
 859        estr_nucl=0.0d0
 860        ecorr3_nucl=0.0d0
 861        ecorr_nucl=0.0d0
 862        ebe_nucl=0.0d0
 863        evdwsb=0.0d0
 864        eelsb=0.0d0
 865        esbloc=0.0d0
 866        evdwpsb=0.0d0
 867        eelpsb=0.0d0
 868        evdwpp=0.0d0
 869        eespp=0.0d0
 870        etors_d_nucl=0.0d0
 871        ecation_nucl=0.0d0
 872       endif
 873 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 874 !      print *,"before ecatcat",wcatcat
 875       if (nres_molec(5).gt.0) then
 876       if (nfgtasks.gt.1) then
 877       if (fg_rank.eq.0) then
 878       call ecatcat(ecationcation)
 879       endif
 880       else
 881       call ecatcat(ecationcation)
 882       endif
 883       if (oldion.gt.0) then
 884       call ecat_prot(ecation_prot)
 885       else
 886       call ecats_prot_amber(ecation_prot)
 887       endif
 888       else
 889       ecationcation=0.0d0
 890       ecation_prot=0.0d0
 891       endif
 892       if ((nres_molec(2).gt.0).and.(nres_molec(1).gt.0)) then
 893       call eprot_sc_base(escbase)
 894       call epep_sc_base(epepbase)
 895       call eprot_sc_phosphate(escpho)
 896       call eprot_pep_phosphate(epeppho)
 897       else
 898       epepbase=0.0
 899       escbase=0.0
 900       escpho=0.0
 901       epeppho=0.0
 902       endif
 903 !      call ecatcat(ecationcation)
 904 !      print *,"after ebend", wtor_nucl
 905 #ifdef TIMING
 906       time_enecalc=time_enecalc+MPI_Wtime()-time00
 907 #endif
 908 !      print *,"Processor",myrank," computed Uconstr"
 909 #ifdef TIMING
 910       time00=MPI_Wtime()
 911 #endif
 912 !
 913 ! Sum the energies
 914 !
 915       energia(1)=evdw
 916 #ifdef SCP14
 917       energia(2)=evdw2-evdw2_14
 918       energia(18)=evdw2_14
 919 #else
 920       energia(2)=evdw2
 921       energia(18)=0.0d0
 922 #endif
 923 #ifdef SPLITELE
 924       energia(3)=ees
 925       energia(16)=evdw1
 926 #else
 927       energia(3)=ees+evdw1
 928       energia(16)=0.0d0
 929 #endif
 930       energia(4)=ecorr
 931       energia(5)=ecorr5
 932       energia(6)=ecorr6
 933       energia(7)=eel_loc
 934       energia(8)=eello_turn3
 935       energia(9)=eello_turn4
 936       energia(10)=eturn6
 937       energia(11)=ebe
 938       energia(12)=escloc
 939       energia(13)=etors
 940       energia(14)=etors_d
 941       energia(15)=ehpb
 942       energia(19)=edihcnstr
 943       energia(17)=estr
 944       energia(20)=Uconst+Uconst_back
 945       energia(21)=esccor
 946       energia(22)=eliptran
 947       energia(23)=Eafmforce
 948       energia(24)=ethetacnstr
 949       energia(25)=etube
 950 !---------------------------------------------------------------
 951       energia(26)=evdwpp
 952       energia(27)=eespp
 953       energia(28)=evdwpsb
 954       energia(29)=eelpsb
 955       energia(30)=evdwsb
 956       energia(31)=eelsb
 957       energia(32)=estr_nucl
 958       energia(33)=ebe_nucl
 959       energia(34)=esbloc
 960       energia(35)=etors_nucl
 961       energia(36)=etors_d_nucl
 962       energia(37)=ecorr_nucl
 963       energia(38)=ecorr3_nucl
 964 !----------------------------------------------------------------------
 965 !    Here are the energies showed per procesor if the are more processors
 966 !    per molecule then we sum it up in sum_energy subroutine
 967 !      print *," Processor",myrank," calls SUM_ENERGY"
 968       energia(42)=ecation_prot
 969       energia(41)=ecationcation
 970       energia(46)=escbase
 971       energia(47)=epepbase
 972       energia(48)=escpho
 973       energia(49)=epeppho
 974 !      energia(50)=ecations_prot_amber
 975       energia(50)=ecation_nucl
 976       energia(51)=ehomology_constr
 977       call sum_energy(energia,.true.)
 978       if (dyn_ss) call dyn_set_nss
 979 !      print *," Processor",myrank," left SUM_ENERGY"
 980 #ifdef TIMING
 981       time_sumene=time_sumene+MPI_Wtime()-time00
 982 #endif
 983 !        call enerprint(energia)
 984 !elwrite(iout,*)"finish etotal"
 985       return
 986       end subroutine etotal
 987 !-----------------------------------------------------------------------------
 988       subroutine sum_energy(energia,reduce)
 989 !      implicit real*8 (a-h,o-z)
 990 !      include 'DIMENSIONS'
 991 #ifndef ISNAN
 992       external proc_proc
 993 #ifdef WINPGI
 994 !MS$ATTRIBUTES C ::  proc_proc
 995 #endif
 996 #endif
 997 #ifdef MPI
 998       include "mpif.h"
 999 #endif
1000 !      include 'COMMON.SETUP'
1001 !      include 'COMMON.IOUNITS'
1002       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
1003 !      include 'COMMON.FFIELD'
1004 !      include 'COMMON.DERIV'
1005 !      include 'COMMON.INTERACT'
1006 !      include 'COMMON.SBRIDGE'
1007 !      include 'COMMON.CHAIN'
1008 !      include 'COMMON.VAR'
1009 !      include 'COMMON.CONTROL'
1010 !      include 'COMMON.TIME1'
1011       logical :: reduce
1012       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
1013       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
1014       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
1015         eliptran,etube, Eafmforce,ethetacnstr
1016       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1017                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1018                       ecorr3_nucl,ehomology_constr
1019       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber,&
1020                       ecation_nucl
1021       real(kind=8) :: escbase,epepbase,escpho,epeppho
1022       integer :: i
1023 #ifdef MPI
1024       integer :: ierr
1025       real(kind=8) :: time00
1026       if (nfgtasks.gt.1 .and. reduce) then
1027
1028 #ifdef DEBUG
1029         write (iout,*) "energies before REDUCE"
1030         call enerprint(energia)
1031         call flush(iout)
1032 #endif
1033         do i=0,n_ene
1034           enebuff(i)=energia(i)
1035         enddo
1036         time00=MPI_Wtime()
1037         call MPI_Barrier(FG_COMM,IERR)
1038         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
1039         time00=MPI_Wtime()
1040         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
1041           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1042 #ifdef DEBUG
1043         write (iout,*) "energies after REDUCE"
1044         call enerprint(energia)
1045         call flush(iout)
1046 #endif
1047         time_Reduce=time_Reduce+MPI_Wtime()-time00
1048       endif
1049       if (fg_rank.eq.0) then
1050 #endif
1051       evdw=energia(1)
1052 #ifdef SCP14
1053       evdw2=energia(2)+energia(18)
1054       evdw2_14=energia(18)
1055 #else
1056       evdw2=energia(2)
1057 #endif
1058 #ifdef SPLITELE
1059       ees=energia(3)
1060       evdw1=energia(16)
1061 #else
1062       ees=energia(3)
1063       evdw1=0.0d0
1064 #endif
1065       ecorr=energia(4)
1066       ecorr5=energia(5)
1067       ecorr6=energia(6)
1068       eel_loc=energia(7)
1069       eello_turn3=energia(8)
1070       eello_turn4=energia(9)
1071       eturn6=energia(10)
1072       ebe=energia(11)
1073       escloc=energia(12)
1074       etors=energia(13)
1075       etors_d=energia(14)
1076       ehpb=energia(15)
1077       edihcnstr=energia(19)
1078       estr=energia(17)
1079       Uconst=energia(20)
1080       esccor=energia(21)
1081       eliptran=energia(22)
1082       Eafmforce=energia(23)
1083       ethetacnstr=energia(24)
1084       etube=energia(25)
1085       evdwpp=energia(26)
1086       eespp=energia(27)
1087       evdwpsb=energia(28)
1088       eelpsb=energia(29)
1089       evdwsb=energia(30)
1090       eelsb=energia(31)
1091       estr_nucl=energia(32)
1092       ebe_nucl=energia(33)
1093       esbloc=energia(34)
1094       etors_nucl=energia(35)
1095       etors_d_nucl=energia(36)
1096       ecorr_nucl=energia(37)
1097       ecorr3_nucl=energia(38)
1098       ecation_prot=energia(42)
1099       ecationcation=energia(41)
1100       escbase=energia(46)
1101       epepbase=energia(47)
1102       escpho=energia(48)
1103       epeppho=energia(49)
1104       ecation_nucl=energia(50)
1105       ehomology_constr=energia(51)
1106 !      ecations_prot_amber=energia(50)
1107
1108 !      energia(41)=ecation_prot
1109 !      energia(42)=ecationcation
1110
1111
1112 #ifdef SPLITELE
1113       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
1114        +wang*ebe+wtor*etors+wscloc*escloc &
1115        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1116        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1117        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1118        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1119        +Eafmforce+ethetacnstr+ehomology_constr  &
1120        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1121        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1122        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1123        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1124        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1125        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho+wcatnucl*ecation_nucl
1126 #else
1127       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
1128        +wang*ebe+wtor*etors+wscloc*escloc &
1129        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1130        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1131        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1132        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1133        +Eafmforce+ethetacnstr+ehomology_constr &
1134        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1135        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1136        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1137        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1138        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1139        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho+wcatnucl*ecation_nucl
1140 #endif
1141       energia(0)=etot
1142 ! detecting NaNQ
1143 #ifdef ISNAN
1144 #ifdef AIX
1145       if (isnan(etot).ne.0) energia(0)=1.0d+99
1146 #else
1147       if (isnan(etot)) energia(0)=1.0d+99
1148 #endif
1149 #else
1150       i=0
1151 #ifdef WINPGI
1152       idumm=proc_proc(etot,i)
1153 #else
1154       call proc_proc(etot,i)
1155 #endif
1156       if(i.eq.1)energia(0)=1.0d+99
1157 #endif
1158 #ifdef MPI
1159       endif
1160 #endif
1161 !      call enerprint(energia)
1162       call flush(iout)
1163       return
1164       end subroutine sum_energy
1165 !-----------------------------------------------------------------------------
1166       subroutine rescale_weights(t_bath)
1167 !      implicit real*8 (a-h,o-z)
1168 #ifdef MPI
1169       include 'mpif.h'
1170 #endif
1171 !      include 'DIMENSIONS'
1172 !      include 'COMMON.IOUNITS'
1173 !      include 'COMMON.FFIELD'
1174 !      include 'COMMON.SBRIDGE'
1175       real(kind=8) :: kfac=2.4d0
1176       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
1177 !el local variables
1178       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
1179       real(kind=8) :: T0=3.0d2
1180       integer :: ierror
1181 !      facT=temp0/t_bath
1182 !      facT=2*temp0/(t_bath+temp0)
1183       if (rescale_mode.eq.0) then
1184         facT(1)=1.0d0
1185         facT(2)=1.0d0
1186         facT(3)=1.0d0
1187         facT(4)=1.0d0
1188         facT(5)=1.0d0
1189         facT(6)=1.0d0
1190       else if (rescale_mode.eq.1) then
1191         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
1192         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1193         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1194         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1195         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1196 #ifdef WHAM_RUN
1197 !#if defined(WHAM_RUN) || defined(CLUSTER)
1198 #if defined(FUNCTH)
1199 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
1200         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1201 #elif defined(FUNCT)
1202         facT(6)=t_bath/T0
1203 #else
1204         facT(6)=1.0d0
1205 #endif
1206 #endif
1207       else if (rescale_mode.eq.2) then
1208         x=t_bath/temp0
1209         x2=x*x
1210         x3=x2*x
1211         x4=x3*x
1212         x5=x4*x
1213         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
1214         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
1215         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
1216         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
1217         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
1218 #ifdef WHAM_RUN
1219 !#if defined(WHAM_RUN) || defined(CLUSTER)
1220 #if defined(FUNCTH)
1221         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1222 #elif defined(FUNCT)
1223         facT(6)=t_bath/T0
1224 #else
1225         facT(6)=1.0d0
1226 #endif
1227 #endif
1228       else
1229         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1230         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1231 #ifdef MPI
1232        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1233 #endif
1234        stop 555
1235       endif
1236       welec=weights(3)*fact(1)
1237       wcorr=weights(4)*fact(3)
1238       wcorr5=weights(5)*fact(4)
1239       wcorr6=weights(6)*fact(5)
1240       wel_loc=weights(7)*fact(2)
1241       wturn3=weights(8)*fact(2)
1242       wturn4=weights(9)*fact(3)
1243       wturn6=weights(10)*fact(5)
1244       wtor=weights(13)*fact(1)
1245       wtor_d=weights(14)*fact(2)
1246       wsccor=weights(21)*fact(1)
1247       welpsb=weights(28)*fact(1)
1248       wcorr_nucl= weights(37)*fact(1)
1249       wcorr3_nucl=weights(38)*fact(2)
1250       wtor_nucl=  weights(35)*fact(1)
1251       wtor_d_nucl=weights(36)*fact(2)
1252       wpepbase=weights(47)*fact(1)
1253       return
1254       end subroutine rescale_weights
1255 !-----------------------------------------------------------------------------
1256       subroutine enerprint(energia)
1257 !      implicit real*8 (a-h,o-z)
1258 !      include 'DIMENSIONS'
1259 !      include 'COMMON.IOUNITS'
1260 !      include 'COMMON.FFIELD'
1261 !      include 'COMMON.SBRIDGE'
1262 !      include 'COMMON.MD'
1263       real(kind=8) :: energia(0:n_ene)
1264 !el local variables
1265       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
1266       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
1267       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
1268        etube,ethetacnstr,Eafmforce
1269       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1270                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1271                       ecorr3_nucl,ehomology_constr
1272       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber,&
1273                       ecation_nucl
1274       real(kind=8) :: escbase,epepbase,escpho,epeppho
1275
1276       etot=energia(0)
1277       evdw=energia(1)
1278       evdw2=energia(2)
1279 #ifdef SCP14
1280       evdw2=energia(2)+energia(18)
1281 #else
1282       evdw2=energia(2)
1283 #endif
1284       ees=energia(3)
1285 #ifdef SPLITELE
1286       evdw1=energia(16)
1287 #endif
1288       ecorr=energia(4)
1289       ecorr5=energia(5)
1290       ecorr6=energia(6)
1291       eel_loc=energia(7)
1292       eello_turn3=energia(8)
1293       eello_turn4=energia(9)
1294       eello_turn6=energia(10)
1295       ebe=energia(11)
1296       escloc=energia(12)
1297       etors=energia(13)
1298       etors_d=energia(14)
1299       ehpb=energia(15)
1300       edihcnstr=energia(19)
1301       estr=energia(17)
1302       Uconst=energia(20)
1303       esccor=energia(21)
1304       eliptran=energia(22)
1305       Eafmforce=energia(23)
1306       ethetacnstr=energia(24)
1307       etube=energia(25)
1308       evdwpp=energia(26)
1309       eespp=energia(27)
1310       evdwpsb=energia(28)
1311       eelpsb=energia(29)
1312       evdwsb=energia(30)
1313       eelsb=energia(31)
1314       estr_nucl=energia(32)
1315       ebe_nucl=energia(33)
1316       esbloc=energia(34)
1317       etors_nucl=energia(35)
1318       etors_d_nucl=energia(36)
1319       ecorr_nucl=energia(37)
1320       ecorr3_nucl=energia(38)
1321       ecation_prot=energia(42)
1322       ecationcation=energia(41)
1323       escbase=energia(46)
1324       epepbase=energia(47)
1325       escpho=energia(48)
1326       epeppho=energia(49)
1327       ecation_nucl=energia(50)
1328       ehomology_constr=energia(51)
1329
1330 !      ecations_prot_amber=energia(50)
1331 #ifdef SPLITELE
1332       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
1333         estr,wbond,ebe,wang,&
1334         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1335         ecorr,wcorr,&
1336         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1337         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
1338         edihcnstr,ethetacnstr,ebr*nss,&
1339         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
1340         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
1341         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1342         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1343         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1344         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat, &
1345         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1346         ecation_nucl,wcatnucl,ehomology_constr,etot
1347    10 format (/'Virtual-chain energies:'// &
1348        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1349        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1350        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1351        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
1352        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1353        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1354        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1355        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1356        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1357        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1358        ' (SS bridges & dist. cnstr.)'/ &
1359        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1360        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1361        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1362        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1363        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1364        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1365        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1366        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1367        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1368        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1369        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1370        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1371        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1372        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1373        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1374        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1375        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1376        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1377        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1378        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1379        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1380        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1381        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1382        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1383        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1384        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1385        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1386        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1387        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1388        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1389        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1390        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1391        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1392        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1393        'ECATBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(cation nucl-base)'/&
1394        'H_CONS=',1pE16.6,' (Homology model constraints energy)'/&
1395        'ETOT=  ',1pE16.6,' (total)')
1396 #else
1397       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1398         estr,wbond,ebe,wang,&
1399         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1400         ecorr,wcorr,&
1401         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1402         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1403         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforce,     &
1404         etube,wtube, ehomology_constr,&
1405         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1406         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1407         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1408         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1409         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat,  &
1410         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1411         ecation_nucl,wcatnucl,ehomology_constr,etot
1412    10 format (/'Virtual-chain energies:'// &
1413        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1414        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1415        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1416        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1417        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1418        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1419        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1420        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1421        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1422        ' (SS bridges & dist. cnstr.)'/ &
1423        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1424        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1425        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1426        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1427        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1428        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1429        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1430        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1431        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1432        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1433        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1434        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1435        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1436        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1437        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1438        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1439        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1440        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1441        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1442        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1443        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1444        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1445        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1446        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1447        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1448        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1449        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1450        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1451        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1452        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1453        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1454        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1455        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1456        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1457        'ECATBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(cation nucl-base)'/&
1458        'H_CONS=',1pE16.6,' (Homology model constraints energy)'/&
1459        'ETOT=  ',1pE16.6,' (total)')
1460 #endif
1461       return
1462       end subroutine enerprint
1463 !-----------------------------------------------------------------------------
1464       subroutine elj(evdw)
1465 !
1466 ! This subroutine calculates the interaction energy of nonbonded side chains
1467 ! assuming the LJ potential of interaction.
1468 !
1469 !      implicit real*8 (a-h,o-z)
1470 !      include 'DIMENSIONS'
1471       real(kind=8),parameter :: accur=1.0d-10
1472 !      include 'COMMON.GEO'
1473 !      include 'COMMON.VAR'
1474 !      include 'COMMON.LOCAL'
1475 !      include 'COMMON.CHAIN'
1476 !      include 'COMMON.DERIV'
1477 !      include 'COMMON.INTERACT'
1478 !      include 'COMMON.TORSION'
1479 !      include 'COMMON.SBRIDGE'
1480 !      include 'COMMON.NAMES'
1481 !      include 'COMMON.IOUNITS'
1482 !      include 'COMMON.CONTACTS'
1483       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1484       integer :: num_conti
1485 !el local variables
1486       integer :: i,itypi,iint,j,itypi1,itypj,k
1487       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij,sslipi,ssgradlipi,&
1488        aa,bb,sslipj,ssgradlipj
1489       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1490       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1491
1492 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1493       evdw=0.0D0
1494 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1495 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1496 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1497 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1498
1499       do i=iatsc_s,iatsc_e
1500         itypi=iabs(itype(i,1))
1501         if (itypi.eq.ntyp1) cycle
1502         itypi1=iabs(itype(i+1,1))
1503         xi=c(1,nres+i)
1504         yi=c(2,nres+i)
1505         zi=c(3,nres+i)
1506         call to_box(xi,yi,zi)
1507         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1508
1509 ! Change 12/1/95
1510         num_conti=0
1511 !
1512 ! Calculate SC interaction energy.
1513 !
1514         do iint=1,nint_gr(i)
1515 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1516 !d   &                  'iend=',iend(i,iint)
1517           do j=istart(i,iint),iend(i,iint)
1518             itypj=iabs(itype(j,1))
1519             if (itypj.eq.ntyp1) cycle
1520             xj=c(1,nres+j)-xi
1521             yj=c(2,nres+j)-yi
1522             zj=c(3,nres+j)-zi
1523             call to_box(xj,yj,zj)
1524             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1525             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1526              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1527             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1528              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1529             xj=boxshift(xj-xi,boxxsize)
1530             yj=boxshift(yj-yi,boxysize)
1531             zj=boxshift(zj-zi,boxzsize)
1532 ! Change 12/1/95 to calculate four-body interactions
1533             rij=xj*xj+yj*yj+zj*zj
1534             rrij=1.0D0/rij
1535 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1536             eps0ij=eps(itypi,itypj)
1537             fac=rrij**expon2
1538             e1=fac*fac*aa_aq(itypi,itypj)
1539             e2=fac*bb_aq(itypi,itypj)
1540             evdwij=e1+e2
1541 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1542 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1543 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1544 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1545 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1546 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1547             evdw=evdw+evdwij
1548 !
1549 ! Calculate the components of the gradient in DC and X
1550 !
1551             fac=-rrij*(e1+evdwij)
1552             gg(1)=xj*fac
1553             gg(2)=yj*fac
1554             gg(3)=zj*fac
1555             do k=1,3
1556               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1557               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1558               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1559               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1560             enddo
1561 !grad            do k=i,j-1
1562 !grad              do l=1,3
1563 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1564 !grad              enddo
1565 !grad            enddo
1566 !
1567 ! 12/1/95, revised on 5/20/97
1568 !
1569 ! Calculate the contact function. The ith column of the array JCONT will
1570 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1571 ! greater than I). The arrays FACONT and GACONT will contain the values of
1572 ! the contact function and its derivative.
1573 !
1574 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1575 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1576 ! Uncomment next line, if the correlation interactions are contact function only
1577             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1578               rij=dsqrt(rij)
1579               sigij=sigma(itypi,itypj)
1580               r0ij=rs0(itypi,itypj)
1581 !
1582 ! Check whether the SC's are not too far to make a contact.
1583 !
1584               rcut=1.5d0*r0ij
1585               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1586 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1587 !
1588               if (fcont.gt.0.0D0) then
1589 ! If the SC-SC distance if close to sigma, apply spline.
1590 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1591 !Adam &             fcont1,fprimcont1)
1592 !Adam           fcont1=1.0d0-fcont1
1593 !Adam           if (fcont1.gt.0.0d0) then
1594 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1595 !Adam             fcont=fcont*fcont1
1596 !Adam           endif
1597 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1598 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1599 !ga             do k=1,3
1600 !ga               gg(k)=gg(k)*eps0ij
1601 !ga             enddo
1602 !ga             eps0ij=-evdwij*eps0ij
1603 ! Uncomment for AL's type of SC correlation interactions.
1604 !adam           eps0ij=-evdwij
1605                 num_conti=num_conti+1
1606                 jcont(num_conti,i)=j
1607                 facont(num_conti,i)=fcont*eps0ij
1608                 fprimcont=eps0ij*fprimcont/rij
1609                 fcont=expon*fcont
1610 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1611 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1612 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1613 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1614                 gacont(1,num_conti,i)=-fprimcont*xj
1615                 gacont(2,num_conti,i)=-fprimcont*yj
1616                 gacont(3,num_conti,i)=-fprimcont*zj
1617 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1618 !d              write (iout,'(2i3,3f10.5)')
1619 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1620               endif
1621             endif
1622           enddo      ! j
1623         enddo        ! iint
1624 ! Change 12/1/95
1625         num_cont(i)=num_conti
1626       enddo          ! i
1627       do i=1,nct
1628         do j=1,3
1629           gvdwc(j,i)=expon*gvdwc(j,i)
1630           gvdwx(j,i)=expon*gvdwx(j,i)
1631         enddo
1632       enddo
1633 !******************************************************************************
1634 !
1635 !                              N O T E !!!
1636 !
1637 ! To save time, the factor of EXPON has been extracted from ALL components
1638 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1639 ! use!
1640 !
1641 !******************************************************************************
1642       return
1643       end subroutine elj
1644 !-----------------------------------------------------------------------------
1645       subroutine eljk(evdw)
1646 !
1647 ! This subroutine calculates the interaction energy of nonbonded side chains
1648 ! assuming the LJK potential of interaction.
1649 !
1650 !      implicit real*8 (a-h,o-z)
1651 !      include 'DIMENSIONS'
1652 !      include 'COMMON.GEO'
1653 !      include 'COMMON.VAR'
1654 !      include 'COMMON.LOCAL'
1655 !      include 'COMMON.CHAIN'
1656 !      include 'COMMON.DERIV'
1657 !      include 'COMMON.INTERACT'
1658 !      include 'COMMON.IOUNITS'
1659 !      include 'COMMON.NAMES'
1660       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1661       logical :: scheck
1662 !el local variables
1663       integer :: i,iint,j,itypi,itypi1,k,itypj
1664       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij, &
1665          sslipi,ssgradlipi, sslipj,ssgradlipj, aa, bb
1666       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1667
1668 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1669       evdw=0.0D0
1670       do i=iatsc_s,iatsc_e
1671         itypi=iabs(itype(i,1))
1672         if (itypi.eq.ntyp1) cycle
1673         itypi1=iabs(itype(i+1,1))
1674         xi=c(1,nres+i)
1675         yi=c(2,nres+i)
1676         zi=c(3,nres+i)
1677         call to_box(xi,yi,zi)
1678         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1679
1680 !
1681 ! Calculate SC interaction energy.
1682 !
1683         do iint=1,nint_gr(i)
1684           do j=istart(i,iint),iend(i,iint)
1685             itypj=iabs(itype(j,1))
1686             if (itypj.eq.ntyp1) cycle
1687             xj=c(1,nres+j)-xi
1688             yj=c(2,nres+j)-yi
1689             zj=c(3,nres+j)-zi
1690             call to_box(xj,yj,zj)
1691             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1692             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1693              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1694             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1695              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1696             xj=boxshift(xj-xi,boxxsize)
1697             yj=boxshift(yj-yi,boxysize)
1698             zj=boxshift(zj-zi,boxzsize)
1699             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1700             fac_augm=rrij**expon
1701             e_augm=augm(itypi,itypj)*fac_augm
1702             r_inv_ij=dsqrt(rrij)
1703             rij=1.0D0/r_inv_ij
1704             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1705             fac=r_shift_inv**expon
1706             e1=fac*fac*aa_aq(itypi,itypj)
1707             e2=fac*bb_aq(itypi,itypj)
1708             evdwij=e_augm+e1+e2
1709 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1710 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1711 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1712 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1713 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1714 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1715 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1716             evdw=evdw+evdwij
1717 !
1718 ! Calculate the components of the gradient in DC and X
1719 !
1720             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1721             gg(1)=xj*fac
1722             gg(2)=yj*fac
1723             gg(3)=zj*fac
1724             do k=1,3
1725               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1726               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1727               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1728               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1729             enddo
1730 !grad            do k=i,j-1
1731 !grad              do l=1,3
1732 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1733 !grad              enddo
1734 !grad            enddo
1735           enddo      ! j
1736         enddo        ! iint
1737       enddo          ! i
1738       do i=1,nct
1739         do j=1,3
1740           gvdwc(j,i)=expon*gvdwc(j,i)
1741           gvdwx(j,i)=expon*gvdwx(j,i)
1742         enddo
1743       enddo
1744       return
1745       end subroutine eljk
1746 !-----------------------------------------------------------------------------
1747       subroutine ebp(evdw)
1748 !
1749 ! This subroutine calculates the interaction energy of nonbonded side chains
1750 ! assuming the Berne-Pechukas potential of interaction.
1751 !
1752       use comm_srutu
1753       use calc_data
1754 !      implicit real*8 (a-h,o-z)
1755 !      include 'DIMENSIONS'
1756 !      include 'COMMON.GEO'
1757 !      include 'COMMON.VAR'
1758 !      include 'COMMON.LOCAL'
1759 !      include 'COMMON.CHAIN'
1760 !      include 'COMMON.DERIV'
1761 !      include 'COMMON.NAMES'
1762 !      include 'COMMON.INTERACT'
1763 !      include 'COMMON.IOUNITS'
1764 !      include 'COMMON.CALC'
1765       use comm_srutu
1766 !el      integer :: icall
1767 !el      common /srutu/ icall
1768 !     double precision rrsave(maxdim)
1769       logical :: lprn
1770 !el local variables
1771       integer :: iint,itypi,itypi1,itypj
1772       real(kind=8) :: rrij,xi,yi,zi, sslipi,ssgradlipi, sslipj, &
1773         ssgradlipj, aa, bb
1774       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1775
1776 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1777       evdw=0.0D0
1778 !     if (icall.eq.0) then
1779 !       lprn=.true.
1780 !     else
1781         lprn=.false.
1782 !     endif
1783 !el      ind=0
1784       do i=iatsc_s,iatsc_e
1785         itypi=iabs(itype(i,1))
1786         if (itypi.eq.ntyp1) cycle
1787         itypi1=iabs(itype(i+1,1))
1788         xi=c(1,nres+i)
1789         yi=c(2,nres+i)
1790         zi=c(3,nres+i)
1791         call to_box(xi,yi,zi)
1792         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1793         dxi=dc_norm(1,nres+i)
1794         dyi=dc_norm(2,nres+i)
1795         dzi=dc_norm(3,nres+i)
1796 !        dsci_inv=dsc_inv(itypi)
1797         dsci_inv=vbld_inv(i+nres)
1798 !
1799 ! Calculate SC interaction energy.
1800 !
1801         do iint=1,nint_gr(i)
1802           do j=istart(i,iint),iend(i,iint)
1803 !el            ind=ind+1
1804             itypj=iabs(itype(j,1))
1805             if (itypj.eq.ntyp1) cycle
1806 !            dscj_inv=dsc_inv(itypj)
1807             dscj_inv=vbld_inv(j+nres)
1808             chi1=chi(itypi,itypj)
1809             chi2=chi(itypj,itypi)
1810             chi12=chi1*chi2
1811             chip1=chip(itypi)
1812             chip2=chip(itypj)
1813             chip12=chip1*chip2
1814             alf1=alp(itypi)
1815             alf2=alp(itypj)
1816             alf12=0.5D0*(alf1+alf2)
1817 ! For diagnostics only!!!
1818 !           chi1=0.0D0
1819 !           chi2=0.0D0
1820 !           chi12=0.0D0
1821 !           chip1=0.0D0
1822 !           chip2=0.0D0
1823 !           chip12=0.0D0
1824 !           alf1=0.0D0
1825 !           alf2=0.0D0
1826 !           alf12=0.0D0
1827             xj=c(1,nres+j)-xi
1828             yj=c(2,nres+j)-yi
1829             zj=c(3,nres+j)-zi
1830             call to_box(xj,yj,zj)
1831             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1832             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1833              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1834             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1835              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1836             xj=boxshift(xj-xi,boxxsize)
1837             yj=boxshift(yj-yi,boxysize)
1838             zj=boxshift(zj-zi,boxzsize)
1839             dxj=dc_norm(1,nres+j)
1840             dyj=dc_norm(2,nres+j)
1841             dzj=dc_norm(3,nres+j)
1842             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1843 !d          if (icall.eq.0) then
1844 !d            rrsave(ind)=rrij
1845 !d          else
1846 !d            rrij=rrsave(ind)
1847 !d          endif
1848             rij=dsqrt(rrij)
1849 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1850             call sc_angular
1851 ! Calculate whole angle-dependent part of epsilon and contributions
1852 ! to its derivatives
1853             fac=(rrij*sigsq)**expon2
1854             e1=fac*fac*aa_aq(itypi,itypj)
1855             e2=fac*bb_aq(itypi,itypj)
1856             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1857             eps2der=evdwij*eps3rt
1858             eps3der=evdwij*eps2rt
1859             evdwij=evdwij*eps2rt*eps3rt
1860             evdw=evdw+evdwij
1861             if (lprn) then
1862             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1863             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1864 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1865 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1866 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1867 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1868 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1869 !d     &        evdwij
1870             endif
1871 ! Calculate gradient components.
1872             e1=e1*eps1*eps2rt**2*eps3rt**2
1873             fac=-expon*(e1+evdwij)
1874             sigder=fac/sigsq
1875             fac=rrij*fac
1876 ! Calculate radial part of the gradient
1877             gg(1)=xj*fac
1878             gg(2)=yj*fac
1879             gg(3)=zj*fac
1880 ! Calculate the angular part of the gradient and sum add the contributions
1881 ! to the appropriate components of the Cartesian gradient.
1882             call sc_grad
1883           enddo      ! j
1884         enddo        ! iint
1885       enddo          ! i
1886 !     stop
1887       return
1888       end subroutine ebp
1889 !-----------------------------------------------------------------------------
1890       subroutine egb(evdw)
1891 !
1892 ! This subroutine calculates the interaction energy of nonbonded side chains
1893 ! assuming the Gay-Berne potential of interaction.
1894 !
1895       use calc_data
1896 !      implicit real*8 (a-h,o-z)
1897 !      include 'DIMENSIONS'
1898 !      include 'COMMON.GEO'
1899 !      include 'COMMON.VAR'
1900 !      include 'COMMON.LOCAL'
1901 !      include 'COMMON.CHAIN'
1902 !      include 'COMMON.DERIV'
1903 !      include 'COMMON.NAMES'
1904 !      include 'COMMON.INTERACT'
1905 !      include 'COMMON.IOUNITS'
1906 !      include 'COMMON.CALC'
1907 !      include 'COMMON.CONTROL'
1908 !      include 'COMMON.SBRIDGE'
1909       logical :: lprn
1910 !el local variables
1911       integer :: iint,itypi,itypi1,itypj,subchap,icont
1912       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1913       real(kind=8) :: evdw,sig0ij
1914       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1915                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1916                     sslipi,sslipj,faclip
1917       integer :: ii
1918       real(kind=8) :: fracinbuf
1919
1920 !cccc      energy_dec=.false.
1921 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1922       evdw=0.0D0
1923       lprn=.false.
1924 !     if (icall.eq.0) lprn=.false.
1925 !el      ind=0
1926       dCAVdOM2=0.0d0
1927       dGCLdOM2=0.0d0
1928       dPOLdOM2=0.0d0
1929       dCAVdOM1=0.0d0
1930       dGCLdOM1=0.0d0
1931       dPOLdOM1=0.0d0
1932 !             write (iout,*) "RWA", g_listscsc_start,g_listscsc_end,i,j
1933
1934       do icont=g_listscsc_start,g_listscsc_end
1935       i=newcontlisti(icont)
1936       j=newcontlistj(icont)
1937 !      write (iout,*) "RWA", g_listscsc_start,g_listscsc_end,i,j
1938 !      do i=iatsc_s,iatsc_e
1939 !C        print *,"I am in EVDW",i
1940         itypi=iabs(itype(i,1))
1941 !        if (i.ne.47) cycle
1942         if (itypi.eq.ntyp1) cycle
1943         itypi1=iabs(itype(i+1,1))
1944         xi=c(1,nres+i)
1945         yi=c(2,nres+i)
1946         zi=c(3,nres+i)
1947         call to_box(xi,yi,zi)
1948         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1949
1950         dxi=dc_norm(1,nres+i)
1951         dyi=dc_norm(2,nres+i)
1952         dzi=dc_norm(3,nres+i)
1953 !        dsci_inv=dsc_inv(itypi)
1954         dsci_inv=vbld_inv(i+nres)
1955 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1956 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1957 !
1958 ! Calculate SC interaction energy.
1959 !
1960 !        do iint=1,nint_gr(i)
1961 !          do j=istart(i,iint),iend(i,iint)
1962             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1963               call dyn_ssbond_ene(i,j,evdwij)
1964               evdw=evdw+evdwij
1965               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1966                               'evdw',i,j,evdwij,' ss'
1967 !              if (energy_dec) write (iout,*) &
1968 !                              'evdw',i,j,evdwij,' ss'
1969              do k=j+1,iend(i,iint)
1970 !C search over all next residues
1971               if (dyn_ss_mask(k)) then
1972 !C check if they are cysteins
1973 !C              write(iout,*) 'k=',k
1974
1975 !c              write(iout,*) "PRZED TRI", evdwij
1976 !               evdwij_przed_tri=evdwij
1977               call triple_ssbond_ene(i,j,k,evdwij)
1978 !c               if(evdwij_przed_tri.ne.evdwij) then
1979 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1980 !c               endif
1981
1982 !c              write(iout,*) "PO TRI", evdwij
1983 !C call the energy function that removes the artifical triple disulfide
1984 !C bond the soubroutine is located in ssMD.F
1985               evdw=evdw+evdwij
1986               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1987                             'evdw',i,j,evdwij,'tss'
1988               endif!dyn_ss_mask(k)
1989              enddo! k
1990             ELSE
1991 !el            ind=ind+1
1992             itypj=iabs(itype(j,1))
1993             if (itypj.eq.ntyp1) cycle
1994 !             if (j.ne.78) cycle
1995 !            dscj_inv=dsc_inv(itypj)
1996             dscj_inv=vbld_inv(j+nres)
1997 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1998 !              1.0d0/vbld(j+nres) !d
1999 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
2000             sig0ij=sigma(itypi,itypj)
2001             chi1=chi(itypi,itypj)
2002             chi2=chi(itypj,itypi)
2003             chi12=chi1*chi2
2004             chip1=chip(itypi)
2005             chip2=chip(itypj)
2006             chip12=chip1*chip2
2007             alf1=alp(itypi)
2008             alf2=alp(itypj)
2009             alf12=0.5D0*(alf1+alf2)
2010 ! For diagnostics only!!!
2011 !           chi1=0.0D0
2012 !           chi2=0.0D0
2013 !           chi12=0.0D0
2014 !           chip1=0.0D0
2015 !           chip2=0.0D0
2016 !           chip12=0.0D0
2017 !           alf1=0.0D0
2018 !           alf2=0.0D0
2019 !           alf12=0.0D0
2020            xj=c(1,nres+j)
2021            yj=c(2,nres+j)
2022            zj=c(3,nres+j)
2023               call to_box(xj,yj,zj)
2024               call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2025 !              write (iout,*) "KWA2", itypi,itypj
2026               aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2027                +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2028               bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2029                +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2030               xj=boxshift(xj-xi,boxxsize)
2031               yj=boxshift(yj-yi,boxysize)
2032               zj=boxshift(zj-zi,boxzsize)
2033             dxj=dc_norm(1,nres+j)
2034             dyj=dc_norm(2,nres+j)
2035             dzj=dc_norm(3,nres+j)
2036 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2037 !            write (iout,*) "j",j," dc_norm",& !d
2038 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2039 !          write(iout,*)"rrij ",rrij
2040 !          write(iout,*)"xj yj zj ", xj, yj, zj
2041 !          write(iout,*)"xi yi zi ", xi, yi, zi
2042 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
2043             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2044             rij=dsqrt(rrij)
2045             sss_ele_cut=sscale_ele(1.0d0/(rij))
2046             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
2047 !            print *,sss_ele_cut,sss_ele_grad,&
2048 !            1.0d0/(rij),r_cut_ele,rlamb_ele
2049             if (sss_ele_cut.le.0.0) cycle
2050 ! Calculate angle-dependent terms of energy and contributions to their
2051 ! derivatives.
2052             call sc_angular
2053             sigsq=1.0D0/sigsq
2054             sig=sig0ij*dsqrt(sigsq)
2055             rij_shift=1.0D0/rij-sig+sig0ij
2056 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
2057 !            "sig0ij",sig0ij
2058 ! for diagnostics; uncomment
2059 !            rij_shift=1.2*sig0ij
2060 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2061             if (rij_shift.le.0.0D0) then
2062               evdw=1.0D20
2063 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2064 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
2065 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2066               return
2067             endif
2068             sigder=-sig*sigsq
2069 !---------------------------------------------------------------
2070             rij_shift=1.0D0/rij_shift
2071             fac=rij_shift**expon
2072             faclip=fac
2073             e1=fac*fac*aa!(itypi,itypj)
2074             e2=fac*bb!(itypi,itypj)
2075             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2076             eps2der=evdwij*eps3rt
2077             eps3der=evdwij*eps2rt
2078 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
2079 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
2080 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
2081             evdwij=evdwij*eps2rt*eps3rt
2082             evdw=evdw+evdwij*sss_ele_cut
2083             if (lprn) then
2084             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2085             epsi=bb**2/aa!(itypi,itypj)
2086             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2087               restyp(itypi,1),i,restyp(itypj,1),j, &
2088               epsi,sigm,chi1,chi2,chip1,chip2, &
2089               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
2090               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
2091               evdwij
2092             endif
2093
2094             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
2095                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
2096 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
2097 !            if (energy_dec) write (iout,*) &
2098 !                             'evdw',i,j,evdwij
2099 !                       print *,"ZALAMKA", evdw
2100
2101 ! Calculate gradient components.
2102             e1=e1*eps1*eps2rt**2*eps3rt**2
2103             fac=-expon*(e1+evdwij)*rij_shift
2104             sigder=fac*sigder
2105             fac=rij*fac
2106 !            print *,'before fac',fac,rij,evdwij
2107             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
2108             *rij
2109 !            print *,'grad part scale',fac,   &
2110 !             evdwij*sss_ele_grad/sss_ele_cut &
2111 !            /sigma(itypi,itypj)*rij
2112 !            fac=0.0d0
2113 ! Calculate the radial part of the gradient
2114             gg(1)=xj*fac
2115             gg(2)=yj*fac
2116             gg(3)=zj*fac
2117 !C Calculate the radial part of the gradient
2118             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
2119        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
2120         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
2121        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2122             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2123             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2124
2125 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
2126 ! Calculate angular part of the gradient.
2127             call sc_grad
2128             ENDIF    ! dyn_ss
2129 !          enddo      ! j
2130 !        enddo        ! iint
2131       enddo          ! i
2132 !       print *,"ZALAMKA", evdw
2133 !      write (iout,*) "Number of loop steps in EGB:",ind
2134 !ccc      energy_dec=.false.
2135       return
2136       end subroutine egb
2137 !-----------------------------------------------------------------------------
2138       subroutine egbv(evdw)
2139 !
2140 ! This subroutine calculates the interaction energy of nonbonded side chains
2141 ! assuming the Gay-Berne-Vorobjev potential of interaction.
2142 !
2143       use comm_srutu
2144       use calc_data
2145 !      implicit real*8 (a-h,o-z)
2146 !      include 'DIMENSIONS'
2147 !      include 'COMMON.GEO'
2148 !      include 'COMMON.VAR'
2149 !      include 'COMMON.LOCAL'
2150 !      include 'COMMON.CHAIN'
2151 !      include 'COMMON.DERIV'
2152 !      include 'COMMON.NAMES'
2153 !      include 'COMMON.INTERACT'
2154 !      include 'COMMON.IOUNITS'
2155 !      include 'COMMON.CALC'
2156       use comm_srutu
2157 !el      integer :: icall
2158 !el      common /srutu/ icall
2159       logical :: lprn
2160 !el local variables
2161       integer :: iint,itypi,itypi1,itypj
2162       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2, &
2163          sigm,sslipi,ssgradlipi, sslipj,ssgradlipj, aa, bb
2164       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
2165
2166 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2167       evdw=0.0D0
2168       lprn=.false.
2169 !     if (icall.eq.0) lprn=.true.
2170 !el      ind=0
2171       do i=iatsc_s,iatsc_e
2172         itypi=iabs(itype(i,1))
2173         if (itypi.eq.ntyp1) cycle
2174         itypi1=iabs(itype(i+1,1))
2175         xi=c(1,nres+i)
2176         yi=c(2,nres+i)
2177         zi=c(3,nres+i)
2178         call to_box(xi,yi,zi)
2179         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2180         dxi=dc_norm(1,nres+i)
2181         dyi=dc_norm(2,nres+i)
2182         dzi=dc_norm(3,nres+i)
2183 !        dsci_inv=dsc_inv(itypi)
2184         dsci_inv=vbld_inv(i+nres)
2185 !
2186 ! Calculate SC interaction energy.
2187 !
2188         do iint=1,nint_gr(i)
2189           do j=istart(i,iint),iend(i,iint)
2190 !el            ind=ind+1
2191             itypj=iabs(itype(j,1))
2192             if (itypj.eq.ntyp1) cycle
2193 !            dscj_inv=dsc_inv(itypj)
2194             dscj_inv=vbld_inv(j+nres)
2195             sig0ij=sigma(itypi,itypj)
2196             r0ij=r0(itypi,itypj)
2197             chi1=chi(itypi,itypj)
2198             chi2=chi(itypj,itypi)
2199             chi12=chi1*chi2
2200             chip1=chip(itypi)
2201             chip2=chip(itypj)
2202             chip12=chip1*chip2
2203             alf1=alp(itypi)
2204             alf2=alp(itypj)
2205             alf12=0.5D0*(alf1+alf2)
2206 ! For diagnostics only!!!
2207 !           chi1=0.0D0
2208 !           chi2=0.0D0
2209 !           chi12=0.0D0
2210 !           chip1=0.0D0
2211 !           chip2=0.0D0
2212 !           chip12=0.0D0
2213 !           alf1=0.0D0
2214 !           alf2=0.0D0
2215 !           alf12=0.0D0
2216             xj=c(1,nres+j)-xi
2217             yj=c(2,nres+j)-yi
2218             zj=c(3,nres+j)-zi
2219            call to_box(xj,yj,zj)
2220            call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2221            aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2222             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2223            bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2224             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2225            xj=boxshift(xj-xi,boxxsize)
2226            yj=boxshift(yj-yi,boxysize)
2227            zj=boxshift(zj-zi,boxzsize)
2228             dxj=dc_norm(1,nres+j)
2229             dyj=dc_norm(2,nres+j)
2230             dzj=dc_norm(3,nres+j)
2231             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2232             rij=dsqrt(rrij)
2233 ! Calculate angle-dependent terms of energy and contributions to their
2234 ! derivatives.
2235             call sc_angular
2236             sigsq=1.0D0/sigsq
2237             sig=sig0ij*dsqrt(sigsq)
2238             rij_shift=1.0D0/rij-sig+r0ij
2239 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2240             if (rij_shift.le.0.0D0) then
2241               evdw=1.0D20
2242               return
2243             endif
2244             sigder=-sig*sigsq
2245 !---------------------------------------------------------------
2246             rij_shift=1.0D0/rij_shift
2247             fac=rij_shift**expon
2248             e1=fac*fac*aa_aq(itypi,itypj)
2249             e2=fac*bb_aq(itypi,itypj)
2250             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2251             eps2der=evdwij*eps3rt
2252             eps3der=evdwij*eps2rt
2253             fac_augm=rrij**expon
2254             e_augm=augm(itypi,itypj)*fac_augm
2255             evdwij=evdwij*eps2rt*eps3rt
2256             evdw=evdw+evdwij+e_augm
2257             if (lprn) then
2258             sigm=dabs(aa_aq(itypi,itypj)/&
2259             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
2260             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
2261             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2262               restyp(itypi,1),i,restyp(itypj,1),j,&
2263               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
2264               chi1,chi2,chip1,chip2,&
2265               eps1,eps2rt**2,eps3rt**2,&
2266               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
2267               evdwij+e_augm
2268             endif
2269 ! Calculate gradient components.
2270             e1=e1*eps1*eps2rt**2*eps3rt**2
2271             fac=-expon*(e1+evdwij)*rij_shift
2272             sigder=fac*sigder
2273             fac=rij*fac-2*expon*rrij*e_augm
2274 ! Calculate the radial part of the gradient
2275             gg(1)=xj*fac
2276             gg(2)=yj*fac
2277             gg(3)=zj*fac
2278 ! Calculate angular part of the gradient.
2279             call sc_grad
2280           enddo      ! j
2281         enddo        ! iint
2282       enddo          ! i
2283       end subroutine egbv
2284 !-----------------------------------------------------------------------------
2285 !el      subroutine sc_angular in module geometry
2286 !-----------------------------------------------------------------------------
2287       subroutine e_softsphere(evdw)
2288 !
2289 ! This subroutine calculates the interaction energy of nonbonded side chains
2290 ! assuming the LJ potential of interaction.
2291 !
2292 !      implicit real*8 (a-h,o-z)
2293 !      include 'DIMENSIONS'
2294       real(kind=8),parameter :: accur=1.0d-10
2295 !      include 'COMMON.GEO'
2296 !      include 'COMMON.VAR'
2297 !      include 'COMMON.LOCAL'
2298 !      include 'COMMON.CHAIN'
2299 !      include 'COMMON.DERIV'
2300 !      include 'COMMON.INTERACT'
2301 !      include 'COMMON.TORSION'
2302 !      include 'COMMON.SBRIDGE'
2303 !      include 'COMMON.NAMES'
2304 !      include 'COMMON.IOUNITS'
2305 !      include 'COMMON.CONTACTS'
2306       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
2307 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2308 !el local variables
2309       integer :: i,iint,j,itypi,itypi1,itypj,k
2310       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
2311       real(kind=8) :: fac
2312
2313       evdw=0.0D0
2314       do i=iatsc_s,iatsc_e
2315         itypi=iabs(itype(i,1))
2316         if (itypi.eq.ntyp1) cycle
2317         itypi1=iabs(itype(i+1,1))
2318         xi=c(1,nres+i)
2319         yi=c(2,nres+i)
2320         zi=c(3,nres+i)
2321         call to_box(xi,yi,zi)
2322
2323 !
2324 ! Calculate SC interaction energy.
2325 !
2326         do iint=1,nint_gr(i)
2327 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2328 !d   &                  'iend=',iend(i,iint)
2329           do j=istart(i,iint),iend(i,iint)
2330             itypj=iabs(itype(j,1))
2331             if (itypj.eq.ntyp1) cycle
2332             xj=boxshift(c(1,nres+j)-xi,boxxsize)
2333             yj=boxshift(c(2,nres+j)-yi,boxysize)
2334             zj=boxshift(c(3,nres+j)-zi,boxzsize)
2335             rij=xj*xj+yj*yj+zj*zj
2336 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2337             r0ij=r0(itypi,itypj)
2338             r0ijsq=r0ij*r0ij
2339 !            print *,i,j,r0ij,dsqrt(rij)
2340             if (rij.lt.r0ijsq) then
2341               evdwij=0.25d0*(rij-r0ijsq)**2
2342               fac=rij-r0ijsq
2343             else
2344               evdwij=0.0d0
2345               fac=0.0d0
2346             endif
2347             evdw=evdw+evdwij
2348 !
2349 ! Calculate the components of the gradient in DC and X
2350 !
2351             gg(1)=xj*fac
2352             gg(2)=yj*fac
2353             gg(3)=zj*fac
2354             do k=1,3
2355               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2356               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2357               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2358               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2359             enddo
2360 !grad            do k=i,j-1
2361 !grad              do l=1,3
2362 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2363 !grad              enddo
2364 !grad            enddo
2365           enddo ! j
2366         enddo ! iint
2367       enddo ! i
2368       return
2369       end subroutine e_softsphere
2370 !-----------------------------------------------------------------------------
2371       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2372 !
2373 ! Soft-sphere potential of p-p interaction
2374 !
2375 !      implicit real*8 (a-h,o-z)
2376 !      include 'DIMENSIONS'
2377 !      include 'COMMON.CONTROL'
2378 !      include 'COMMON.IOUNITS'
2379 !      include 'COMMON.GEO'
2380 !      include 'COMMON.VAR'
2381 !      include 'COMMON.LOCAL'
2382 !      include 'COMMON.CHAIN'
2383 !      include 'COMMON.DERIV'
2384 !      include 'COMMON.INTERACT'
2385 !      include 'COMMON.CONTACTS'
2386 !      include 'COMMON.TORSION'
2387 !      include 'COMMON.VECTORS'
2388 !      include 'COMMON.FFIELD'
2389       real(kind=8),dimension(3) :: ggg
2390 !d      write(iout,*) 'In EELEC_soft_sphere'
2391 !el local variables
2392       integer :: i,j,k,num_conti,iteli,itelj
2393       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2394       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2395       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2396
2397       ees=0.0D0
2398       evdw1=0.0D0
2399       eel_loc=0.0d0
2400       eello_turn3=0.0d0
2401       eello_turn4=0.0d0
2402 !el      ind=0
2403       do i=iatel_s,iatel_e
2404         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2405         dxi=dc(1,i)
2406         dyi=dc(2,i)
2407         dzi=dc(3,i)
2408         xmedi=c(1,i)+0.5d0*dxi
2409         ymedi=c(2,i)+0.5d0*dyi
2410         zmedi=c(3,i)+0.5d0*dzi
2411         call to_box(xmedi,ymedi,zmedi)
2412         num_conti=0
2413 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2414         do j=ielstart(i),ielend(i)
2415           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2416 !el          ind=ind+1
2417           iteli=itel(i)
2418           itelj=itel(j)
2419           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2420           r0ij=rpp(iteli,itelj)
2421           r0ijsq=r0ij*r0ij
2422           dxj=dc(1,j)
2423           dyj=dc(2,j)
2424           dzj=dc(3,j)
2425           xj=c(1,j)+0.5D0*dxj-xmedi
2426           yj=c(2,j)+0.5D0*dyj-ymedi
2427           zj=c(3,j)+0.5D0*dzj-zmedi
2428           call to_box(xj,yj,zj)
2429           xj=boxshift(xj-xmedi,boxxsize)
2430           yj=boxshift(yj-ymedi,boxysize)
2431           zj=boxshift(zj-zmedi,boxzsize)
2432           rij=xj*xj+yj*yj+zj*zj
2433           if (rij.lt.r0ijsq) then
2434             evdw1ij=0.25d0*(rij-r0ijsq)**2
2435             fac=rij-r0ijsq
2436           else
2437             evdw1ij=0.0d0
2438             fac=0.0d0
2439           endif
2440           evdw1=evdw1+evdw1ij
2441 !
2442 ! Calculate contributions to the Cartesian gradient.
2443 !
2444           ggg(1)=fac*xj
2445           ggg(2)=fac*yj
2446           ggg(3)=fac*zj
2447           do k=1,3
2448             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2449             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2450           enddo
2451 !
2452 ! Loop over residues i+1 thru j-1.
2453 !
2454 !grad          do k=i+1,j-1
2455 !grad            do l=1,3
2456 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2457 !grad            enddo
2458 !grad          enddo
2459         enddo ! j
2460       enddo   ! i
2461 !grad      do i=nnt,nct-1
2462 !grad        do k=1,3
2463 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2464 !grad        enddo
2465 !grad        do j=i+1,nct-1
2466 !grad          do k=1,3
2467 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2468 !grad          enddo
2469 !grad        enddo
2470 !grad      enddo
2471       return
2472       end subroutine eelec_soft_sphere
2473 !-----------------------------------------------------------------------------
2474       subroutine vec_and_deriv
2475 !      implicit real*8 (a-h,o-z)
2476 !      include 'DIMENSIONS'
2477 #ifdef MPI
2478       include 'mpif.h'
2479 #endif
2480 !      include 'COMMON.IOUNITS'
2481 !      include 'COMMON.GEO'
2482 !      include 'COMMON.VAR'
2483 !      include 'COMMON.LOCAL'
2484 !      include 'COMMON.CHAIN'
2485 !      include 'COMMON.VECTORS'
2486 !      include 'COMMON.SETUP'
2487 !      include 'COMMON.TIME1'
2488       real(kind=8),dimension(3,3,2) :: uyder,uzder
2489       real(kind=8),dimension(2) :: vbld_inv_temp
2490 ! Compute the local reference systems. For reference system (i), the
2491 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2492 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2493 !el local variables
2494       integer :: i,j,k,l
2495       real(kind=8) :: facy,fac,costh
2496
2497 #ifdef PARVEC
2498       do i=ivec_start,ivec_end
2499 #else
2500       do i=1,nres-1
2501 #endif
2502           if (i.eq.nres-1) then
2503 ! Case of the last full residue
2504 ! Compute the Z-axis
2505             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2506             costh=dcos(pi-theta(nres))
2507             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2508             do k=1,3
2509               uz(k,i)=fac*uz(k,i)
2510             enddo
2511 ! Compute the derivatives of uz
2512             uzder(1,1,1)= 0.0d0
2513             uzder(2,1,1)=-dc_norm(3,i-1)
2514             uzder(3,1,1)= dc_norm(2,i-1)
2515             uzder(1,2,1)= dc_norm(3,i-1)
2516             uzder(2,2,1)= 0.0d0
2517             uzder(3,2,1)=-dc_norm(1,i-1)
2518             uzder(1,3,1)=-dc_norm(2,i-1)
2519             uzder(2,3,1)= dc_norm(1,i-1)
2520             uzder(3,3,1)= 0.0d0
2521             uzder(1,1,2)= 0.0d0
2522             uzder(2,1,2)= dc_norm(3,i)
2523             uzder(3,1,2)=-dc_norm(2,i)
2524             uzder(1,2,2)=-dc_norm(3,i)
2525             uzder(2,2,2)= 0.0d0
2526             uzder(3,2,2)= dc_norm(1,i)
2527             uzder(1,3,2)= dc_norm(2,i)
2528             uzder(2,3,2)=-dc_norm(1,i)
2529             uzder(3,3,2)= 0.0d0
2530 ! Compute the Y-axis
2531             facy=fac
2532             do k=1,3
2533               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2534             enddo
2535 ! Compute the derivatives of uy
2536             do j=1,3
2537               do k=1,3
2538                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2539                               -dc_norm(k,i)*dc_norm(j,i-1)
2540                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2541               enddo
2542               uyder(j,j,1)=uyder(j,j,1)-costh
2543               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2544             enddo
2545             do j=1,2
2546               do k=1,3
2547                 do l=1,3
2548                   uygrad(l,k,j,i)=uyder(l,k,j)
2549                   uzgrad(l,k,j,i)=uzder(l,k,j)
2550                 enddo
2551               enddo
2552             enddo
2553             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2554             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2555             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2556             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2557           else
2558 ! Other residues
2559 ! Compute the Z-axis
2560             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2561             costh=dcos(pi-theta(i+2))
2562             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2563             do k=1,3
2564               uz(k,i)=fac*uz(k,i)
2565             enddo
2566 ! Compute the derivatives of uz
2567             uzder(1,1,1)= 0.0d0
2568             uzder(2,1,1)=-dc_norm(3,i+1)
2569             uzder(3,1,1)= dc_norm(2,i+1)
2570             uzder(1,2,1)= dc_norm(3,i+1)
2571             uzder(2,2,1)= 0.0d0
2572             uzder(3,2,1)=-dc_norm(1,i+1)
2573             uzder(1,3,1)=-dc_norm(2,i+1)
2574             uzder(2,3,1)= dc_norm(1,i+1)
2575             uzder(3,3,1)= 0.0d0
2576             uzder(1,1,2)= 0.0d0
2577             uzder(2,1,2)= dc_norm(3,i)
2578             uzder(3,1,2)=-dc_norm(2,i)
2579             uzder(1,2,2)=-dc_norm(3,i)
2580             uzder(2,2,2)= 0.0d0
2581             uzder(3,2,2)= dc_norm(1,i)
2582             uzder(1,3,2)= dc_norm(2,i)
2583             uzder(2,3,2)=-dc_norm(1,i)
2584             uzder(3,3,2)= 0.0d0
2585 ! Compute the Y-axis
2586             facy=fac
2587             do k=1,3
2588               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2589             enddo
2590 ! Compute the derivatives of uy
2591             do j=1,3
2592               do k=1,3
2593                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2594                               -dc_norm(k,i)*dc_norm(j,i+1)
2595                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2596               enddo
2597               uyder(j,j,1)=uyder(j,j,1)-costh
2598               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2599             enddo
2600             do j=1,2
2601               do k=1,3
2602                 do l=1,3
2603                   uygrad(l,k,j,i)=uyder(l,k,j)
2604                   uzgrad(l,k,j,i)=uzder(l,k,j)
2605                 enddo
2606               enddo
2607             enddo
2608             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2609             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2610             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2611             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2612           endif
2613       enddo
2614       do i=1,nres-1
2615         vbld_inv_temp(1)=vbld_inv(i+1)
2616         if (i.lt.nres-1) then
2617           vbld_inv_temp(2)=vbld_inv(i+2)
2618           else
2619           vbld_inv_temp(2)=vbld_inv(i)
2620           endif
2621         do j=1,2
2622           do k=1,3
2623             do l=1,3
2624               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2625               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2626             enddo
2627           enddo
2628         enddo
2629       enddo
2630 #if defined(PARVEC) && defined(MPI)
2631       if (nfgtasks1.gt.1) then
2632         time00=MPI_Wtime()
2633 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2634 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2635 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2636         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2637          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2638          FG_COMM1,IERR)
2639         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2640          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2641          FG_COMM1,IERR)
2642         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2643          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2644          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2645         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2646          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2647          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2648         time_gather=time_gather+MPI_Wtime()-time00
2649       endif
2650 !      if (fg_rank.eq.0) then
2651 !        write (iout,*) "Arrays UY and UZ"
2652 !        do i=1,nres-1
2653 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2654 !     &     (uz(k,i),k=1,3)
2655 !        enddo
2656 !      endif
2657 #endif
2658       return
2659       end subroutine vec_and_deriv
2660 !-----------------------------------------------------------------------------
2661       subroutine check_vecgrad
2662 !      implicit real*8 (a-h,o-z)
2663 !      include 'DIMENSIONS'
2664 !      include 'COMMON.IOUNITS'
2665 !      include 'COMMON.GEO'
2666 !      include 'COMMON.VAR'
2667 !      include 'COMMON.LOCAL'
2668 !      include 'COMMON.CHAIN'
2669 !      include 'COMMON.VECTORS'
2670       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2671       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2672       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2673       real(kind=8),dimension(3) :: erij
2674       real(kind=8) :: delta=1.0d-7
2675 !el local variables
2676       integer :: i,j,k,l
2677
2678       call vec_and_deriv
2679 !d      do i=1,nres
2680 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2681 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2682 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2683 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2684 !d     &     (dc_norm(if90,i),if90=1,3)
2685 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2686 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2687 !d          write(iout,'(a)')
2688 !d      enddo
2689       do i=1,nres
2690         do j=1,2
2691           do k=1,3
2692             do l=1,3
2693               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2694               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2695             enddo
2696           enddo
2697         enddo
2698       enddo
2699       call vec_and_deriv
2700       do i=1,nres
2701         do j=1,3
2702           uyt(j,i)=uy(j,i)
2703           uzt(j,i)=uz(j,i)
2704         enddo
2705       enddo
2706       do i=1,nres
2707 !d        write (iout,*) 'i=',i
2708         do k=1,3
2709           erij(k)=dc_norm(k,i)
2710         enddo
2711         do j=1,3
2712           do k=1,3
2713             dc_norm(k,i)=erij(k)
2714           enddo
2715           dc_norm(j,i)=dc_norm(j,i)+delta
2716 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2717 !          do k=1,3
2718 !            dc_norm(k,i)=dc_norm(k,i)/fac
2719 !          enddo
2720 !          write (iout,*) (dc_norm(k,i),k=1,3)
2721 !          write (iout,*) (erij(k),k=1,3)
2722           call vec_and_deriv
2723           do k=1,3
2724             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2725             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2726             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2727             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2728           enddo
2729 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2730 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2731 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2732         enddo
2733         do k=1,3
2734           dc_norm(k,i)=erij(k)
2735         enddo
2736 !d        do k=1,3
2737 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2738 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2739 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2740 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2741 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2742 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2743 !d          write (iout,'(a)')
2744 !d        enddo
2745       enddo
2746       return
2747       end subroutine check_vecgrad
2748 !-----------------------------------------------------------------------------
2749       subroutine set_matrices
2750 !      implicit real*8 (a-h,o-z)
2751 !      include 'DIMENSIONS'
2752 #ifdef MPI
2753       include "mpif.h"
2754 !      include "COMMON.SETUP"
2755       integer :: IERR
2756       integer :: status(MPI_STATUS_SIZE)
2757 #endif
2758 !      include 'COMMON.IOUNITS'
2759 !      include 'COMMON.GEO'
2760 !      include 'COMMON.VAR'
2761 !      include 'COMMON.LOCAL'
2762 !      include 'COMMON.CHAIN'
2763 !      include 'COMMON.DERIV'
2764 !      include 'COMMON.INTERACT'
2765 !      include 'COMMON.CONTACTS'
2766 !      include 'COMMON.TORSION'
2767 !      include 'COMMON.VECTORS'
2768 !      include 'COMMON.FFIELD'
2769       real(kind=8) :: auxvec(2),auxmat(2,2)
2770       integer :: i,iti1,iti,k,l
2771       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2,cost1,sint1,&
2772        sint1sq,sint1cub,sint1cost1,b1k,b2k,aux
2773 !       print *,"in set matrices"
2774 !
2775 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2776 ! to calculate the el-loc multibody terms of various order.
2777 !
2778 !AL el      mu=0.0d0
2779
2780 #ifdef PARMAT
2781       do i=ivec_start+2,ivec_end+2
2782 #else
2783       do i=3,nres+1
2784 #endif
2785         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2786           if (itype(i-2,1).eq.0) then
2787           iti = nloctyp
2788           else
2789           iti = itype2loc(itype(i-2,1))
2790           endif
2791         else
2792           iti=nloctyp
2793         endif
2794 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2795         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2796           iti1 = itype2loc(itype(i-1,1))
2797         else
2798           iti1=nloctyp
2799         endif
2800 !        print *,i,itype(i-2,1),iti
2801 #ifdef NEWCORR
2802         cost1=dcos(theta(i-1))
2803         sint1=dsin(theta(i-1))
2804         sint1sq=sint1*sint1
2805         sint1cub=sint1sq*sint1
2806         sint1cost1=2*sint1*cost1
2807 !        print *,"cost1",cost1,theta(i-1)
2808 !c        write (iout,*) "bnew1",i,iti
2809 !c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2810 !c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2811 !c        write (iout,*) "bnew2",i,iti
2812 !c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2813 !c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2814         k=1
2815 !        print *,bnew1(1,k,iti),"bnew1"
2816         do k=1,2
2817           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2818 !          print *,b1k
2819 !          write(*,*) shape(b1)
2820 !          if(.not.allocated(b1)) print *, "WTF?"
2821           b1(k,i-2)=sint1*b1k
2822 !
2823 !             print *,b1(k,i-2)
2824
2825           gtb1(k,i-2)=cost1*b1k-sint1sq*&
2826                    (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2827 !             print *,gtb1(k,i-2)
2828
2829           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2830           b2(k,i-2)=sint1*b2k
2831 !             print *,b2(k,i-2)
2832
2833           gtb2(k,i-2)=cost1*b2k-sint1sq*&
2834                    (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2835 !             print *,gtb2(k,i-2)
2836
2837         enddo
2838 !        print *,b1k,b2k
2839         do k=1,2
2840           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2841           cc(1,k,i-2)=sint1sq*aux
2842           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*&
2843                    (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2844           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2845           dd(1,k,i-2)=sint1sq*aux
2846           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*&
2847                    (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2848         enddo
2849 !        print *,"after cc"
2850         cc(2,1,i-2)=cc(1,2,i-2)
2851         cc(2,2,i-2)=-cc(1,1,i-2)
2852         gtcc(2,1,i-2)=gtcc(1,2,i-2)
2853         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2854         dd(2,1,i-2)=dd(1,2,i-2)
2855         dd(2,2,i-2)=-dd(1,1,i-2)
2856         gtdd(2,1,i-2)=gtdd(1,2,i-2)
2857         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2858 !        print *,"after dd"
2859
2860         do k=1,2
2861           do l=1,2
2862             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2863             EE(l,k,i-2)=sint1sq*aux
2864             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2865           enddo
2866         enddo
2867         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2868         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2869         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2870         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2871         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2872         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2873         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2874 !        print *,"after ee"
2875
2876 !c        b1tilde(1,i-2)=b1(1,i-2)
2877 !c        b1tilde(2,i-2)=-b1(2,i-2)
2878 !c        b2tilde(1,i-2)=b2(1,i-2)
2879 !c        b2tilde(2,i-2)=-b2(2,i-2)
2880 #ifdef DEBUG
2881         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2882         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
2883         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
2884         write (iout,*) 'theta=', theta(i-1)
2885 #endif
2886 #else
2887         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2888 !         write(iout,*) "i,",molnum(i),nloctyp
2889 !         print *, "i,",molnum(i),i,itype(i-2,1)
2890         if (molnum(i).eq.1) then
2891           if (itype(i-2,1).eq.ntyp1) then
2892            iti=nloctyp
2893           else
2894           iti = itype2loc(itype(i-2,1))
2895           endif
2896         else
2897           iti=nloctyp
2898         endif
2899         else
2900           iti=nloctyp
2901         endif
2902 !c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
2903 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2904         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2905           iti1 = itype2loc(itype(i-1,1))
2906         else
2907           iti1=nloctyp
2908         endif
2909 !        print *,i,iti
2910         b1(1,i-2)=b(3,iti)
2911         b1(2,i-2)=b(5,iti)
2912         b2(1,i-2)=b(2,iti)
2913         b2(2,i-2)=b(4,iti)
2914         do k=1,2
2915           do l=1,2
2916            CC(k,l,i-2)=ccold(k,l,iti)
2917            DD(k,l,i-2)=ddold(k,l,iti)
2918            EE(k,l,i-2)=eeold(k,l,iti)
2919           enddo
2920         enddo
2921 #endif
2922         b1tilde(1,i-2)= b1(1,i-2)
2923         b1tilde(2,i-2)=-b1(2,i-2)
2924         b2tilde(1,i-2)= b2(1,i-2)
2925         b2tilde(2,i-2)=-b2(2,i-2)
2926 !c
2927         Ctilde(1,1,i-2)= CC(1,1,i-2)
2928         Ctilde(1,2,i-2)= CC(1,2,i-2)
2929         Ctilde(2,1,i-2)=-CC(2,1,i-2)
2930         Ctilde(2,2,i-2)=-CC(2,2,i-2)
2931 !c
2932         Dtilde(1,1,i-2)= DD(1,1,i-2)
2933         Dtilde(1,2,i-2)= DD(1,2,i-2)
2934         Dtilde(2,1,i-2)=-DD(2,1,i-2)
2935         Dtilde(2,2,i-2)=-DD(2,2,i-2)
2936       enddo
2937 #ifdef PARMAT
2938       do i=ivec_start+2,ivec_end+2
2939 #else
2940       do i=3,nres+1
2941 #endif
2942
2943 !      print *,i,"i"
2944         if (i .lt. nres+1) then
2945           sin1=dsin(phi(i))
2946           cos1=dcos(phi(i))
2947           sintab(i-2)=sin1
2948           costab(i-2)=cos1
2949           obrot(1,i-2)=cos1
2950           obrot(2,i-2)=sin1
2951           sin2=dsin(2*phi(i))
2952           cos2=dcos(2*phi(i))
2953           sintab2(i-2)=sin2
2954           costab2(i-2)=cos2
2955           obrot2(1,i-2)=cos2
2956           obrot2(2,i-2)=sin2
2957           Ug(1,1,i-2)=-cos1
2958           Ug(1,2,i-2)=-sin1
2959           Ug(2,1,i-2)=-sin1
2960           Ug(2,2,i-2)= cos1
2961           Ug2(1,1,i-2)=-cos2
2962           Ug2(1,2,i-2)=-sin2
2963           Ug2(2,1,i-2)=-sin2
2964           Ug2(2,2,i-2)= cos2
2965         else
2966           costab(i-2)=1.0d0
2967           sintab(i-2)=0.0d0
2968           obrot(1,i-2)=1.0d0
2969           obrot(2,i-2)=0.0d0
2970           obrot2(1,i-2)=0.0d0
2971           obrot2(2,i-2)=0.0d0
2972           Ug(1,1,i-2)=1.0d0
2973           Ug(1,2,i-2)=0.0d0
2974           Ug(2,1,i-2)=0.0d0
2975           Ug(2,2,i-2)=1.0d0
2976           Ug2(1,1,i-2)=0.0d0
2977           Ug2(1,2,i-2)=0.0d0
2978           Ug2(2,1,i-2)=0.0d0
2979           Ug2(2,2,i-2)=0.0d0
2980         endif
2981         if (i .gt. 3 .and. i .lt. nres+1) then
2982           obrot_der(1,i-2)=-sin1
2983           obrot_der(2,i-2)= cos1
2984           Ugder(1,1,i-2)= sin1
2985           Ugder(1,2,i-2)=-cos1
2986           Ugder(2,1,i-2)=-cos1
2987           Ugder(2,2,i-2)=-sin1
2988           dwacos2=cos2+cos2
2989           dwasin2=sin2+sin2
2990           obrot2_der(1,i-2)=-dwasin2
2991           obrot2_der(2,i-2)= dwacos2
2992           Ug2der(1,1,i-2)= dwasin2
2993           Ug2der(1,2,i-2)=-dwacos2
2994           Ug2der(2,1,i-2)=-dwacos2
2995           Ug2der(2,2,i-2)=-dwasin2
2996         else
2997           obrot_der(1,i-2)=0.0d0
2998           obrot_der(2,i-2)=0.0d0
2999           Ugder(1,1,i-2)=0.0d0
3000           Ugder(1,2,i-2)=0.0d0
3001           Ugder(2,1,i-2)=0.0d0
3002           Ugder(2,2,i-2)=0.0d0
3003           obrot2_der(1,i-2)=0.0d0
3004           obrot2_der(2,i-2)=0.0d0
3005           Ug2der(1,1,i-2)=0.0d0
3006           Ug2der(1,2,i-2)=0.0d0
3007           Ug2der(2,1,i-2)=0.0d0
3008           Ug2der(2,2,i-2)=0.0d0
3009         endif
3010 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3011         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3012            if (itype(i-2,1).eq.0) then
3013           iti=ntortyp+1
3014            else
3015           iti = itype2loc(itype(i-2,1))
3016            endif
3017         else
3018           iti=nloctyp
3019         endif
3020 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3021         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3022            if (itype(i-1,1).eq.0) then
3023           iti1=nloctyp
3024            else
3025           iti1 = itype2loc(itype(i-1,1))
3026            endif
3027         else
3028           iti1=nloctyp
3029         endif
3030 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
3031 !d        write (iout,*) '*******i',i,' iti1',iti
3032 !        write (iout,*) 'b1',b1(:,iti)
3033 !        write (iout,*) 'b2',b2(:,i-2)
3034 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
3035 !        if (i .gt. iatel_s+2) then
3036         if (i .gt. nnt+2) then
3037           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3038 #ifdef NEWCORR
3039           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3040 !c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3041 #endif
3042
3043           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3044           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3045           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3046           then
3047           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3048           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3049           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3050           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3051           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3052           endif
3053         else
3054           do k=1,2
3055             Ub2(k,i-2)=0.0d0
3056             Ctobr(k,i-2)=0.0d0
3057             Dtobr2(k,i-2)=0.0d0
3058             do l=1,2
3059               EUg(l,k,i-2)=0.0d0
3060               CUg(l,k,i-2)=0.0d0
3061               DUg(l,k,i-2)=0.0d0
3062               DtUg2(l,k,i-2)=0.0d0
3063             enddo
3064           enddo
3065         endif
3066         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3067         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3068         do k=1,2
3069           muder(k,i-2)=Ub2der(k,i-2)
3070         enddo
3071 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3072         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3073           if (itype(i-1,1).eq.0) then
3074            iti1=nloctyp
3075           elseif (itype(i-1,1).le.ntyp) then
3076             iti1 = itype2loc(itype(i-1,1))
3077           else
3078             iti1=nloctyp
3079           endif
3080         else
3081           iti1=nloctyp
3082         endif
3083         do k=1,2
3084           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3085         enddo
3086         if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
3087         if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,i-1)
3088         if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
3089 !d        write (iout,*) 'mu1',mu1(:,i-2)
3090 !d        write (iout,*) 'mu2',mu2(:,i-2)
3091         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3092         then
3093         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3094         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3095         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3096         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3097         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3098 ! Vectors and matrices dependent on a single virtual-bond dihedral.
3099         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3100         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3101         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3102         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3103         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3104         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3105         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3106         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3107         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3108         endif
3109       enddo
3110 ! Matrices dependent on two consecutive virtual-bond dihedrals.
3111 ! The order of matrices is from left to right.
3112       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3113       then
3114 !      do i=max0(ivec_start,2),ivec_end
3115       do i=2,nres-1
3116         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3117         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3118         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3119         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3120         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3121         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3122         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3123         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3124       enddo
3125       endif
3126 #if defined(MPI) && defined(PARMAT)
3127 #ifdef DEBUG
3128 !      if (fg_rank.eq.0) then
3129         write (iout,*) "Arrays UG and UGDER before GATHER"
3130         do i=1,nres-1
3131           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3132            ((ug(l,k,i),l=1,2),k=1,2),&
3133            ((ugder(l,k,i),l=1,2),k=1,2)
3134         enddo
3135         write (iout,*) "Arrays UG2 and UG2DER"
3136         do i=1,nres-1
3137           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3138            ((ug2(l,k,i),l=1,2),k=1,2),&
3139            ((ug2der(l,k,i),l=1,2),k=1,2)
3140         enddo
3141         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3142         do i=1,nres-1
3143           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3144            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3145            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3146         enddo
3147         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3148         do i=1,nres-1
3149           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3150            costab(i),sintab(i),costab2(i),sintab2(i)
3151         enddo
3152         write (iout,*) "Array MUDER"
3153         do i=1,nres-1
3154           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3155         enddo
3156 !      endif
3157 #endif
3158       if (nfgtasks.gt.1) then
3159         time00=MPI_Wtime()
3160 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3161 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3162 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3163 #ifdef MATGATHER
3164         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
3165          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3166          FG_COMM1,IERR)
3167         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
3168          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3169          FG_COMM1,IERR)
3170         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
3171          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3172          FG_COMM1,IERR)
3173         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
3174          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3175          FG_COMM1,IERR)
3176         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
3177          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3178          FG_COMM1,IERR)
3179         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
3180          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3181          FG_COMM1,IERR)
3182         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
3183          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
3184          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3185         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
3186          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
3187          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3188         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
3189          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
3190          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3191         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
3192          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
3193          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3194         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3195         then
3196         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
3197          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3198          FG_COMM1,IERR)
3199         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
3200          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3201          FG_COMM1,IERR)
3202         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
3203          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3204          FG_COMM1,IERR)
3205        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
3206          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3207          FG_COMM1,IERR)
3208         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
3209          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3210          FG_COMM1,IERR)
3211         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
3212          ivec_count(fg_rank1),&
3213          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3214          FG_COMM1,IERR)
3215         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
3216          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3217          FG_COMM1,IERR)
3218         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
3219          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3220          FG_COMM1,IERR)
3221         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
3222          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3223          FG_COMM1,IERR)
3224         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
3225          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3226          FG_COMM1,IERR)
3227         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
3228          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3229          FG_COMM1,IERR)
3230         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
3231          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3232          FG_COMM1,IERR)
3233         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
3234          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3235          FG_COMM1,IERR)
3236         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
3237          ivec_count(fg_rank1),&
3238          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3239          FG_COMM1,IERR)
3240         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
3241          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3242          FG_COMM1,IERR)
3243        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
3244          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3245          FG_COMM1,IERR)
3246         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
3247          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3248          FG_COMM1,IERR)
3249        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
3250          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3251          FG_COMM1,IERR)
3252         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
3253          ivec_count(fg_rank1),&
3254          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3255          FG_COMM1,IERR)
3256         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
3257          ivec_count(fg_rank1),&
3258          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3259          FG_COMM1,IERR)
3260         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
3261          ivec_count(fg_rank1),&
3262          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3263          MPI_MAT2,FG_COMM1,IERR)
3264         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
3265          ivec_count(fg_rank1),&
3266          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3267          MPI_MAT2,FG_COMM1,IERR)
3268         endif
3269 #else
3270 ! Passes matrix info through the ring
3271       isend=fg_rank1
3272       irecv=fg_rank1-1
3273       if (irecv.lt.0) irecv=nfgtasks1-1
3274       iprev=irecv
3275       inext=fg_rank1+1
3276       if (inext.ge.nfgtasks1) inext=0
3277       do i=1,nfgtasks1-1
3278 !        write (iout,*) "isend",isend," irecv",irecv
3279 !        call flush(iout)
3280         lensend=lentyp(isend)
3281         lenrecv=lentyp(irecv)
3282 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3283 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3284 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
3285 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3286 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
3287 !        write (iout,*) "Gather ROTAT1"
3288 !        call flush(iout)
3289 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3290 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
3291 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3292 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
3293 !        write (iout,*) "Gather ROTAT2"
3294 !        call flush(iout)
3295         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
3296          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
3297          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
3298          iprev,4400+irecv,FG_COMM,status,IERR)
3299 !        write (iout,*) "Gather ROTAT_OLD"
3300 !        call flush(iout)
3301         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
3302          MPI_PRECOMP11(lensend),inext,5500+isend,&
3303          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
3304          iprev,5500+irecv,FG_COMM,status,IERR)
3305 !        write (iout,*) "Gather PRECOMP11"
3306 !        call flush(iout)
3307         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
3308          MPI_PRECOMP12(lensend),inext,6600+isend,&
3309          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
3310          iprev,6600+irecv,FG_COMM,status,IERR)
3311 !        write (iout,*) "Gather PRECOMP12"
3312 !        call flush(iout)
3313         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3314         then
3315         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
3316          MPI_ROTAT2(lensend),inext,7700+isend,&
3317          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
3318          iprev,7700+irecv,FG_COMM,status,IERR)
3319 !        write (iout,*) "Gather PRECOMP21"
3320 !        call flush(iout)
3321         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
3322          MPI_PRECOMP22(lensend),inext,8800+isend,&
3323          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
3324          iprev,8800+irecv,FG_COMM,status,IERR)
3325 !        write (iout,*) "Gather PRECOMP22"
3326 !        call flush(iout)
3327         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
3328          MPI_PRECOMP23(lensend),inext,9900+isend,&
3329          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
3330          MPI_PRECOMP23(lenrecv),&
3331          iprev,9900+irecv,FG_COMM,status,IERR)
3332 !        write (iout,*) "Gather PRECOMP23"
3333 !        call flush(iout)
3334         endif
3335         isend=irecv
3336         irecv=irecv-1
3337         if (irecv.lt.0) irecv=nfgtasks1-1
3338       enddo
3339 #endif
3340         time_gather=time_gather+MPI_Wtime()-time00
3341       endif
3342 #ifdef DEBUG
3343 !      if (fg_rank.eq.0) then
3344         write (iout,*) "Arrays UG and UGDER"
3345         do i=1,nres-1
3346           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3347            ((ug(l,k,i),l=1,2),k=1,2),&
3348            ((ugder(l,k,i),l=1,2),k=1,2)
3349         enddo
3350         write (iout,*) "Arrays UG2 and UG2DER"
3351         do i=1,nres-1
3352           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3353            ((ug2(l,k,i),l=1,2),k=1,2),&
3354            ((ug2der(l,k,i),l=1,2),k=1,2)
3355         enddo
3356         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3357         do i=1,nres-1
3358           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3359            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3360            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3361         enddo
3362         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3363         do i=1,nres-1
3364           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3365            costab(i),sintab(i),costab2(i),sintab2(i)
3366         enddo
3367         write (iout,*) "Array MUDER"
3368         do i=1,nres-1
3369           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3370         enddo
3371 !      endif
3372 #endif
3373 #endif
3374 !d      do i=1,nres
3375 !d        iti = itortyp(itype(i,1))
3376 !d        write (iout,*) i
3377 !d        do j=1,2
3378 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3379 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3380 !d        enddo
3381 !d      enddo
3382       return
3383       end subroutine set_matrices
3384 !-----------------------------------------------------------------------------
3385       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3386 !
3387 ! This subroutine calculates the average interaction energy and its gradient
3388 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
3389 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3390 ! The potential depends both on the distance of peptide-group centers and on
3391 ! the orientation of the CA-CA virtual bonds.
3392 !
3393       use comm_locel
3394 !      implicit real*8 (a-h,o-z)
3395 #ifdef MPI
3396       include 'mpif.h'
3397 #endif
3398 !      include 'DIMENSIONS'
3399 !      include 'COMMON.CONTROL'
3400 !      include 'COMMON.SETUP'
3401 !      include 'COMMON.IOUNITS'
3402 !      include 'COMMON.GEO'
3403 !      include 'COMMON.VAR'
3404 !      include 'COMMON.LOCAL'
3405 !      include 'COMMON.CHAIN'
3406 !      include 'COMMON.DERIV'
3407 !      include 'COMMON.INTERACT'
3408 !      include 'COMMON.CONTACTS'
3409 !      include 'COMMON.TORSION'
3410 !      include 'COMMON.VECTORS'
3411 !      include 'COMMON.FFIELD'
3412 !      include 'COMMON.TIME1'
3413       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
3414       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3415       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3416 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3417       real(kind=8),dimension(4) :: muij
3418 !el      integer :: num_conti,j1,j2
3419 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3420 !el        dz_normi,xmedi,ymedi,zmedi
3421
3422 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3423 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3424 !el          num_conti,j1,j2
3425
3426 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3427 #ifdef MOMENT
3428       real(kind=8) :: scal_el=1.0d0
3429 #else
3430       real(kind=8) :: scal_el=0.5d0
3431 #endif
3432 ! 12/13/98
3433 ! 13-go grudnia roku pamietnego...
3434       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3435                                              0.0d0,1.0d0,0.0d0,&
3436                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3437 !el local variables
3438       integer :: i,k,j,icont
3439       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
3440       real(kind=8) :: fac,t_eelecij,fracinbuf
3441
3442
3443 !d      write(iout,*) 'In EELEC'
3444 !        print *,"IN EELEC"
3445 !d      do i=1,nloctyp
3446 !d        write(iout,*) 'Type',i
3447 !d        write(iout,*) 'B1',B1(:,i)
3448 !d        write(iout,*) 'B2',B2(:,i)
3449 !d        write(iout,*) 'CC',CC(:,:,i)
3450 !d        write(iout,*) 'DD',DD(:,:,i)
3451 !d        write(iout,*) 'EE',EE(:,:,i)
3452 !d      enddo
3453 !d      call check_vecgrad
3454 !d      stop
3455 !      ees=0.0d0  !AS
3456 !      evdw1=0.0d0
3457 !      eel_loc=0.0d0
3458 !      eello_turn3=0.0d0
3459 !      eello_turn4=0.0d0
3460       t_eelecij=0.0d0
3461       ees=0.0D0
3462       evdw1=0.0D0
3463       eel_loc=0.0d0
3464       eello_turn3=0.0d0
3465       eello_turn4=0.0d0
3466 !
3467
3468       if (icheckgrad.eq.1) then
3469 !el
3470 !        do i=0,2*nres+2
3471 !          dc_norm(1,i)=0.0d0
3472 !          dc_norm(2,i)=0.0d0
3473 !          dc_norm(3,i)=0.0d0
3474 !        enddo
3475         do i=1,nres-1
3476           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3477           do k=1,3
3478             dc_norm(k,i)=dc(k,i)*fac
3479           enddo
3480 !          write (iout,*) 'i',i,' fac',fac
3481         enddo
3482       endif
3483 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3484 !        wturn6
3485       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3486           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3487           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3488 !        call vec_and_deriv
3489 #ifdef TIMING
3490         time01=MPI_Wtime()
3491 #endif
3492 !        print *, "before set matrices"
3493         call set_matrices
3494 !        print *, "after set matrices"
3495
3496 #ifdef TIMING
3497         time_mat=time_mat+MPI_Wtime()-time01
3498 #endif
3499       endif
3500 !       print *, "after set matrices"
3501 !d      do i=1,nres-1
3502 !d        write (iout,*) 'i=',i
3503 !d        do k=1,3
3504 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3505 !d        enddo
3506 !d        do k=1,3
3507 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3508 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3509 !d        enddo
3510 !d      enddo
3511       t_eelecij=0.0d0
3512       ees=0.0D0
3513       evdw1=0.0D0
3514       eel_loc=0.0d0
3515       eello_turn3=0.0d0
3516       eello_turn4=0.0d0
3517 !el      ind=0
3518       do i=1,nres
3519         num_cont_hb(i)=0
3520       enddo
3521 !d      print '(a)','Enter EELEC'
3522 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3523 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3524 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3525       do i=1,nres
3526         gel_loc_loc(i)=0.0d0
3527         gcorr_loc(i)=0.0d0
3528       enddo
3529 !
3530 !
3531 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3532 !
3533 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3534 !
3535
3536
3537 !        print *,"before iturn3 loop"
3538       do i=iturn3_start,iturn3_end
3539         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3540         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3541         dxi=dc(1,i)
3542         dyi=dc(2,i)
3543         dzi=dc(3,i)
3544         dx_normi=dc_norm(1,i)
3545         dy_normi=dc_norm(2,i)
3546         dz_normi=dc_norm(3,i)
3547         xmedi=c(1,i)+0.5d0*dxi
3548         ymedi=c(2,i)+0.5d0*dyi
3549         zmedi=c(3,i)+0.5d0*dzi
3550         call to_box(xmedi,ymedi,zmedi)
3551         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3552         num_conti=0
3553        call eelecij(i,i+2,ees,evdw1,eel_loc)
3554         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3555         num_cont_hb(i)=num_conti
3556       enddo
3557       do i=iturn4_start,iturn4_end
3558         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3559           .or. itype(i+3,1).eq.ntyp1 &
3560           .or. itype(i+4,1).eq.ntyp1) cycle
3561 !        print *,"before2",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3562         dxi=dc(1,i)
3563         dyi=dc(2,i)
3564         dzi=dc(3,i)
3565         dx_normi=dc_norm(1,i)
3566         dy_normi=dc_norm(2,i)
3567         dz_normi=dc_norm(3,i)
3568         xmedi=c(1,i)+0.5d0*dxi
3569         ymedi=c(2,i)+0.5d0*dyi
3570         zmedi=c(3,i)+0.5d0*dzi
3571         call to_box(xmedi,ymedi,zmedi)
3572         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3573         num_conti=num_cont_hb(i)
3574         call eelecij(i,i+3,ees,evdw1,eel_loc)
3575         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3576         call eturn4(i,eello_turn4)
3577 !        print *,"before",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3578         num_cont_hb(i)=num_conti
3579       enddo   ! i
3580 !
3581 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3582 !
3583 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3584 !      do i=iatel_s,iatel_e
3585 ! JPRDLC
3586        do icont=g_listpp_start,g_listpp_end
3587         i=newcontlistppi(icont)
3588         j=newcontlistppj(icont)
3589         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3590         dxi=dc(1,i)
3591         dyi=dc(2,i)
3592         dzi=dc(3,i)
3593         dx_normi=dc_norm(1,i)
3594         dy_normi=dc_norm(2,i)
3595         dz_normi=dc_norm(3,i)
3596         xmedi=c(1,i)+0.5d0*dxi
3597         ymedi=c(2,i)+0.5d0*dyi
3598         zmedi=c(3,i)+0.5d0*dzi
3599         call to_box(xmedi,ymedi,zmedi)
3600         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3601
3602 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3603         num_conti=num_cont_hb(i)
3604 !        do j=ielstart(i),ielend(i)
3605 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3606           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3607           call eelecij(i,j,ees,evdw1,eel_loc)
3608 !        enddo ! j
3609         num_cont_hb(i)=num_conti
3610       enddo   ! i
3611 !      write (iout,*) "Number of loop steps in EELEC:",ind
3612 !d      do i=1,nres
3613 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3614 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3615 !d      enddo
3616 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3617 !cc      eel_loc=eel_loc+eello_turn3
3618 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3619       return
3620       end subroutine eelec
3621 !-----------------------------------------------------------------------------
3622       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3623
3624       use comm_locel
3625 !      implicit real*8 (a-h,o-z)
3626 !      include 'DIMENSIONS'
3627 #ifdef MPI
3628       include "mpif.h"
3629 #endif
3630 !      include 'COMMON.CONTROL'
3631 !      include 'COMMON.IOUNITS'
3632 !      include 'COMMON.GEO'
3633 !      include 'COMMON.VAR'
3634 !      include 'COMMON.LOCAL'
3635 !      include 'COMMON.CHAIN'
3636 !      include 'COMMON.DERIV'
3637 !      include 'COMMON.INTERACT'
3638 !      include 'COMMON.CONTACTS'
3639 !      include 'COMMON.TORSION'
3640 !      include 'COMMON.VECTORS'
3641 !      include 'COMMON.FFIELD'
3642 !      include 'COMMON.TIME1'
3643       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3644       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3645       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3646 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3647       real(kind=8),dimension(4) :: muij
3648       real(kind=8) :: geel_loc_ij,geel_loc_ji
3649       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3650                     dist_temp, dist_init,rlocshield,fracinbuf
3651       integer xshift,yshift,zshift,ilist,iresshield
3652 !el      integer :: num_conti,j1,j2
3653 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3654 !el        dz_normi,xmedi,ymedi,zmedi
3655
3656 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3657 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3658 !el          num_conti,j1,j2
3659
3660 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3661 #ifdef MOMENT
3662       real(kind=8) :: scal_el=1.0d0
3663 #else
3664       real(kind=8) :: scal_el=0.5d0
3665 #endif
3666 ! 12/13/98
3667 ! 13-go grudnia roku pamietnego...
3668       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3669                                              0.0d0,1.0d0,0.0d0,&
3670                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3671 !      integer :: maxconts=nres/4
3672 !el local variables
3673       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3674       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3675       real(kind=8) ::  faclipij2, faclipij
3676       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3677       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3678                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3679                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3680                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3681                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3682                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3683                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3684                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3685 !      maxconts=nres/4
3686 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3687 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3688
3689 !          time00=MPI_Wtime()
3690 !d      write (iout,*) "eelecij",i,j
3691 !          ind=ind+1
3692           iteli=itel(i)
3693           itelj=itel(j)
3694           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3695           aaa=app(iteli,itelj)
3696           bbb=bpp(iteli,itelj)
3697           ael6i=ael6(iteli,itelj)
3698           ael3i=ael3(iteli,itelj)
3699           dxj=dc(1,j)
3700           dyj=dc(2,j)
3701           dzj=dc(3,j)
3702           dx_normj=dc_norm(1,j)
3703           dy_normj=dc_norm(2,j)
3704           dz_normj=dc_norm(3,j)
3705 !          xj=c(1,j)+0.5D0*dxj-xmedi
3706 !          yj=c(2,j)+0.5D0*dyj-ymedi
3707 !          zj=c(3,j)+0.5D0*dzj-zmedi
3708           xj=c(1,j)+0.5D0*dxj
3709           yj=c(2,j)+0.5D0*dyj
3710           zj=c(3,j)+0.5D0*dzj
3711
3712           call to_box(xj,yj,zj)
3713           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
3714           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
3715           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3716           xj=boxshift(xj-xmedi,boxxsize)
3717           yj=boxshift(yj-ymedi,boxysize)
3718           zj=boxshift(zj-zmedi,boxzsize)
3719
3720           rij=xj*xj+yj*yj+zj*zj
3721           rrmij=1.0D0/rij
3722           rij=dsqrt(rij)
3723 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3724             sss_ele_cut=sscale_ele(rij)
3725             sss_ele_grad=sscagrad_ele(rij)
3726 !             sss_ele_cut=1.0d0
3727 !             sss_ele_grad=0.0d0
3728 !            print *,sss_ele_cut,sss_ele_grad,&
3729 !            (rij),r_cut_ele,rlamb_ele
3730             if (sss_ele_cut.le.0.0) go to 128
3731
3732           rmij=1.0D0/rij
3733           r3ij=rrmij*rmij
3734           r6ij=r3ij*r3ij
3735           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3736           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3737           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3738           fac=cosa-3.0D0*cosb*cosg
3739           ev1=aaa*r6ij*r6ij
3740 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3741           if (j.eq.i+2) ev1=scal_el*ev1
3742           ev2=bbb*r6ij
3743           fac3=ael6i*r6ij
3744           fac4=ael3i*r3ij
3745           evdwij=ev1+ev2
3746           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3747           el2=fac4*fac
3748 !          eesij=el1+el2
3749           if (shield_mode.gt.0) then
3750 !C          fac_shield(i)=0.4
3751 !C          fac_shield(j)=0.6
3752           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3753           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3754           eesij=(el1+el2)
3755           ees=ees+eesij*sss_ele_cut
3756 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3757 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3758           else
3759           fac_shield(i)=1.0
3760           fac_shield(j)=1.0
3761           eesij=(el1+el2)
3762           ees=ees+eesij   &
3763             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3764 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3765           endif
3766
3767 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3768           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3769 !          ees=ees+eesij*sss_ele_cut
3770           evdw1=evdw1+evdwij*sss_ele_cut  &
3771            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3772 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3773 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3774 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3775 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3776
3777           if (energy_dec) then
3778 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3779 !                  'evdw1',i,j,evdwij,&
3780 !                  iteli,itelj,aaa,evdw1
3781               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3782               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3783           endif
3784 !
3785 ! Calculate contributions to the Cartesian gradient.
3786 !
3787 #ifdef SPLITELE
3788           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3789               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3790           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3791              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3792           fac1=fac
3793           erij(1)=xj*rmij
3794           erij(2)=yj*rmij
3795           erij(3)=zj*rmij
3796 !
3797 ! Radial derivatives. First process both termini of the fragment (i,j)
3798 !
3799           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3800           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3801           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3802            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3803           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3804             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3805
3806           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3807           (shield_mode.gt.0)) then
3808 !C          print *,i,j
3809           do ilist=1,ishield_list(i)
3810            iresshield=shield_list(ilist,i)
3811            do k=1,3
3812            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3813            *2.0*sss_ele_cut
3814            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3815                    rlocshield &
3816             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3817             *sss_ele_cut
3818             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3819            enddo
3820           enddo
3821           do ilist=1,ishield_list(j)
3822            iresshield=shield_list(ilist,j)
3823            do k=1,3
3824            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3825           *2.0*sss_ele_cut
3826            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3827                    rlocshield &
3828            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3829            *sss_ele_cut
3830            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3831            enddo
3832           enddo
3833           do k=1,3
3834             gshieldc(k,i)=gshieldc(k,i)+ &
3835                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3836            *sss_ele_cut
3837
3838             gshieldc(k,j)=gshieldc(k,j)+ &
3839                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3840            *sss_ele_cut
3841
3842             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3843                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3844            *sss_ele_cut
3845
3846             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3847                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3848            *sss_ele_cut
3849
3850            enddo
3851            endif
3852
3853
3854 !          do k=1,3
3855 !            ghalf=0.5D0*ggg(k)
3856 !            gelc(k,i)=gelc(k,i)+ghalf
3857 !            gelc(k,j)=gelc(k,j)+ghalf
3858 !          enddo
3859 ! 9/28/08 AL Gradient compotents will be summed only at the end
3860           do k=1,3
3861             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3862             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3863           enddo
3864             gelc_long(3,j)=gelc_long(3,j)+  &
3865           ssgradlipj*eesij/2.0d0*lipscale**2&
3866            *sss_ele_cut
3867
3868             gelc_long(3,i)=gelc_long(3,i)+  &
3869           ssgradlipi*eesij/2.0d0*lipscale**2&
3870            *sss_ele_cut
3871
3872
3873 !
3874 ! Loop over residues i+1 thru j-1.
3875 !
3876 !grad          do k=i+1,j-1
3877 !grad            do l=1,3
3878 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3879 !grad            enddo
3880 !grad          enddo
3881           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3882            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3883           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3884            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3885           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3886            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3887
3888 !          do k=1,3
3889 !            ghalf=0.5D0*ggg(k)
3890 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3891 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3892 !          enddo
3893 ! 9/28/08 AL Gradient compotents will be summed only at the end
3894           do k=1,3
3895             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3896             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3897           enddo
3898
3899 !C Lipidic part for scaling weight
3900            gvdwpp(3,j)=gvdwpp(3,j)+ &
3901           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3902            gvdwpp(3,i)=gvdwpp(3,i)+ &
3903           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3904 !! Loop over residues i+1 thru j-1.
3905 !
3906 !grad          do k=i+1,j-1
3907 !grad            do l=1,3
3908 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3909 !grad            enddo
3910 !grad          enddo
3911 #else
3912           facvdw=(ev1+evdwij)*sss_ele_cut &
3913            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3914
3915           facel=(el1+eesij)*sss_ele_cut
3916           fac1=fac
3917           fac=-3*rrmij*(facvdw+facvdw+facel)
3918           erij(1)=xj*rmij
3919           erij(2)=yj*rmij
3920           erij(3)=zj*rmij
3921 !
3922 ! Radial derivatives. First process both termini of the fragment (i,j)
3923 !
3924           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3925           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3926           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3927 !          do k=1,3
3928 !            ghalf=0.5D0*ggg(k)
3929 !            gelc(k,i)=gelc(k,i)+ghalf
3930 !            gelc(k,j)=gelc(k,j)+ghalf
3931 !          enddo
3932 ! 9/28/08 AL Gradient compotents will be summed only at the end
3933           do k=1,3
3934             gelc_long(k,j)=gelc(k,j)+ggg(k)
3935             gelc_long(k,i)=gelc(k,i)-ggg(k)
3936           enddo
3937 !
3938 ! Loop over residues i+1 thru j-1.
3939 !
3940 !grad          do k=i+1,j-1
3941 !grad            do l=1,3
3942 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3943 !grad            enddo
3944 !grad          enddo
3945 ! 9/28/08 AL Gradient compotents will be summed only at the end
3946           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3947            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3948           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3949            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3950           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3951            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3952
3953           do k=1,3
3954             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3955             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3956           enddo
3957            gvdwpp(3,j)=gvdwpp(3,j)+ &
3958           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3959            gvdwpp(3,i)=gvdwpp(3,i)+ &
3960           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3961
3962 #endif
3963 !
3964 ! Angular part
3965 !
3966           ecosa=2.0D0*fac3*fac1+fac4
3967           fac4=-3.0D0*fac4
3968           fac3=-6.0D0*fac3
3969           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3970           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3971           do k=1,3
3972             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3973             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3974           enddo
3975 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3976 !d   &          (dcosg(k),k=1,3)
3977           do k=1,3
3978             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3979              *fac_shield(i)**2*fac_shield(j)**2 &
3980              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3981
3982           enddo
3983 !          do k=1,3
3984 !            ghalf=0.5D0*ggg(k)
3985 !            gelc(k,i)=gelc(k,i)+ghalf
3986 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3987 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3988 !            gelc(k,j)=gelc(k,j)+ghalf
3989 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3990 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3991 !          enddo
3992 !grad          do k=i+1,j-1
3993 !grad            do l=1,3
3994 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3995 !grad            enddo
3996 !grad          enddo
3997           do k=1,3
3998             gelc(k,i)=gelc(k,i) &
3999                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4000                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
4001                      *sss_ele_cut &
4002                      *fac_shield(i)**2*fac_shield(j)**2 &
4003                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4004
4005             gelc(k,j)=gelc(k,j) &
4006                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4007                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4008                      *sss_ele_cut  &
4009                      *fac_shield(i)**2*fac_shield(j)**2  &
4010                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4011
4012             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4013             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4014           enddo
4015
4016           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
4017               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
4018               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4019 !
4020 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4021 !   energy of a peptide unit is assumed in the form of a second-order
4022 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4023 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4024 !   are computed for EVERY pair of non-contiguous peptide groups.
4025 !
4026           if (j.lt.nres-1) then
4027             j1=j+1
4028             j2=j-1
4029           else
4030             j1=j-1
4031             j2=j-2
4032           endif
4033           kkk=0
4034           do k=1,2
4035             do l=1,2
4036               kkk=kkk+1
4037               muij(kkk)=mu(k,i)*mu(l,j)
4038 #ifdef NEWCORR
4039              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4040 !c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4041              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4042              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4043 !c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4044              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4045 #endif
4046
4047             enddo
4048           enddo
4049 !d         write (iout,*) 'EELEC: i',i,' j',j
4050 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
4051 !d          write(iout,*) 'muij',muij
4052           ury=scalar(uy(1,i),erij)
4053           urz=scalar(uz(1,i),erij)
4054           vry=scalar(uy(1,j),erij)
4055           vrz=scalar(uz(1,j),erij)
4056           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4057           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4058           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4059           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4060           fac=dsqrt(-ael6i)*r3ij
4061           a22=a22*fac
4062           a23=a23*fac
4063           a32=a32*fac
4064           a33=a33*fac
4065 !d          write (iout,'(4i5,4f10.5)')
4066 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
4067 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4068 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4069 !d     &      uy(:,j),uz(:,j)
4070 !d          write (iout,'(4f10.5)')
4071 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4072 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4073 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
4074 !d           write (iout,'(9f10.5/)')
4075 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4076 ! Derivatives of the elements of A in virtual-bond vectors
4077           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4078           do k=1,3
4079             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4080             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4081             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4082             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4083             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4084             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4085             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4086             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4087             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4088             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4089             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4090             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4091           enddo
4092 ! Compute radial contributions to the gradient
4093           facr=-3.0d0*rrmij
4094           a22der=a22*facr
4095           a23der=a23*facr
4096           a32der=a32*facr
4097           a33der=a33*facr
4098           agg(1,1)=a22der*xj
4099           agg(2,1)=a22der*yj
4100           agg(3,1)=a22der*zj
4101           agg(1,2)=a23der*xj
4102           agg(2,2)=a23der*yj
4103           agg(3,2)=a23der*zj
4104           agg(1,3)=a32der*xj
4105           agg(2,3)=a32der*yj
4106           agg(3,3)=a32der*zj
4107           agg(1,4)=a33der*xj
4108           agg(2,4)=a33der*yj
4109           agg(3,4)=a33der*zj
4110 ! Add the contributions coming from er
4111           fac3=-3.0d0*fac
4112           do k=1,3
4113             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4114             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4115             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4116             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4117           enddo
4118           do k=1,3
4119 ! Derivatives in DC(i)
4120 !grad            ghalf1=0.5d0*agg(k,1)
4121 !grad            ghalf2=0.5d0*agg(k,2)
4122 !grad            ghalf3=0.5d0*agg(k,3)
4123 !grad            ghalf4=0.5d0*agg(k,4)
4124             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
4125             -3.0d0*uryg(k,2)*vry)!+ghalf1
4126             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
4127             -3.0d0*uryg(k,2)*vrz)!+ghalf2
4128             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
4129             -3.0d0*urzg(k,2)*vry)!+ghalf3
4130             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
4131             -3.0d0*urzg(k,2)*vrz)!+ghalf4
4132 ! Derivatives in DC(i+1)
4133             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
4134             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4135             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
4136             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4137             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
4138             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4139             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
4140             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4141 ! Derivatives in DC(j)
4142             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
4143             -3.0d0*vryg(k,2)*ury)!+ghalf1
4144             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
4145             -3.0d0*vrzg(k,2)*ury)!+ghalf2
4146             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
4147             -3.0d0*vryg(k,2)*urz)!+ghalf3
4148             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
4149             -3.0d0*vrzg(k,2)*urz)!+ghalf4
4150 ! Derivatives in DC(j+1) or DC(nres-1)
4151             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
4152             -3.0d0*vryg(k,3)*ury)
4153             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
4154             -3.0d0*vrzg(k,3)*ury)
4155             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
4156             -3.0d0*vryg(k,3)*urz)
4157             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
4158             -3.0d0*vrzg(k,3)*urz)
4159 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
4160 !grad              do l=1,4
4161 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4162 !grad              enddo
4163 !grad            endif
4164           enddo
4165           acipa(1,1)=a22
4166           acipa(1,2)=a23
4167           acipa(2,1)=a32
4168           acipa(2,2)=a33
4169           a22=-a22
4170           a23=-a23
4171           do l=1,2
4172             do k=1,3
4173               agg(k,l)=-agg(k,l)
4174               aggi(k,l)=-aggi(k,l)
4175               aggi1(k,l)=-aggi1(k,l)
4176               aggj(k,l)=-aggj(k,l)
4177               aggj1(k,l)=-aggj1(k,l)
4178             enddo
4179           enddo
4180           if (j.lt.nres-1) then
4181             a22=-a22
4182             a32=-a32
4183             do l=1,3,2
4184               do k=1,3
4185                 agg(k,l)=-agg(k,l)
4186                 aggi(k,l)=-aggi(k,l)
4187                 aggi1(k,l)=-aggi1(k,l)
4188                 aggj(k,l)=-aggj(k,l)
4189                 aggj1(k,l)=-aggj1(k,l)
4190               enddo
4191             enddo
4192           else
4193             a22=-a22
4194             a23=-a23
4195             a32=-a32
4196             a33=-a33
4197             do l=1,4
4198               do k=1,3
4199                 agg(k,l)=-agg(k,l)
4200                 aggi(k,l)=-aggi(k,l)
4201                 aggi1(k,l)=-aggi1(k,l)
4202                 aggj(k,l)=-aggj(k,l)
4203                 aggj1(k,l)=-aggj1(k,l)
4204               enddo
4205             enddo
4206           endif
4207           ENDIF ! WCORR
4208           IF (wel_loc.gt.0.0d0) THEN
4209 ! Contribution to the local-electrostatic energy coming from the i-j pair
4210           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
4211            +a33*muij(4)
4212           if (shield_mode.eq.0) then
4213            fac_shield(i)=1.0
4214            fac_shield(j)=1.0
4215           endif
4216           eel_loc_ij=eel_loc_ij &
4217          *fac_shield(i)*fac_shield(j) &
4218          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4219 !C Now derivative over eel_loc
4220           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
4221          (shield_mode.gt.0)) then
4222 !C          print *,i,j
4223
4224           do ilist=1,ishield_list(i)
4225            iresshield=shield_list(ilist,i)
4226            do k=1,3
4227            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
4228                                                 /fac_shield(i)&
4229            *sss_ele_cut
4230            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4231                    rlocshield  &
4232           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
4233           *sss_ele_cut
4234
4235             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4236            +rlocshield
4237            enddo
4238           enddo
4239           do ilist=1,ishield_list(j)
4240            iresshield=shield_list(ilist,j)
4241            do k=1,3
4242            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
4243                                             /fac_shield(j)   &
4244             *sss_ele_cut
4245            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4246                    rlocshield  &
4247       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
4248        *sss_ele_cut
4249
4250            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4251                   +rlocshield
4252
4253            enddo
4254           enddo
4255
4256           do k=1,3
4257             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
4258                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4259                     *sss_ele_cut
4260             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
4261                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4262                     *sss_ele_cut
4263             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
4264                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4265                     *sss_ele_cut
4266             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
4267                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4268                     *sss_ele_cut
4269
4270            enddo
4271            endif
4272
4273 #ifdef NEWCORR
4274          geel_loc_ij=(a22*gmuij1(1)&
4275           +a23*gmuij1(2)&
4276           +a32*gmuij1(3)&
4277           +a33*gmuij1(4))&
4278          *fac_shield(i)*fac_shield(j)&
4279                     *sss_ele_cut     &
4280          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4281
4282
4283 !c         write(iout,*) "derivative over thatai"
4284 !c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4285 !c     &   a33*gmuij1(4)
4286          gloc(nphi+i,icg)=gloc(nphi+i,icg)+&
4287            geel_loc_ij*wel_loc
4288 !c         write(iout,*) "derivative over thatai-1"
4289 !c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4290 !c     &   a33*gmuij2(4)
4291          geel_loc_ij=&
4292           a22*gmuij2(1)&
4293           +a23*gmuij2(2)&
4294           +a32*gmuij2(3)&
4295           +a33*gmuij2(4)
4296          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+&
4297            geel_loc_ij*wel_loc&
4298          *fac_shield(i)*fac_shield(j)&
4299                     *sss_ele_cut &
4300          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4301
4302
4303 !c  Derivative over j residue
4304          geel_loc_ji=a22*gmuji1(1)&
4305           +a23*gmuji1(2)&
4306           +a32*gmuji1(3)&
4307           +a33*gmuji1(4)
4308 !c         write(iout,*) "derivative over thataj"
4309 !c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4310 !c     &   a33*gmuji1(4)
4311
4312         gloc(nphi+j,icg)=gloc(nphi+j,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
4319          geel_loc_ji=&
4320           +a22*gmuji2(1)&
4321           +a23*gmuji2(2)&
4322           +a32*gmuji2(3)&
4323           +a33*gmuji2(4)
4324 !c         write(iout,*) "derivative over thataj-1"
4325 !c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4326 !c     &   a33*gmuji2(4)
4327          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+&
4328            geel_loc_ji*wel_loc&
4329          *fac_shield(i)*fac_shield(j)&
4330                     *sss_ele_cut &
4331          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4332
4333 #endif
4334
4335 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4336 !           eel_loc_ij=0.0
4337 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4338 !                  'eelloc',i,j,eel_loc_ij
4339           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,8f8.3)') &
4340                   'eelloc',i,j,eel_loc_ij,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4341 !           print *,"EELLOC",i,gel_loc_loc(i-1)
4342
4343 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4344 !          if (energy_dec) write (iout,*) "muij",muij
4345 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
4346
4347           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
4348 ! Partial derivatives in virtual-bond dihedral angles gamma
4349           if (i.gt.1) &
4350           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
4351                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
4352                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
4353                  *sss_ele_cut  &
4354           *fac_shield(i)*fac_shield(j) &
4355           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4356
4357           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
4358                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
4359                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
4360                  *sss_ele_cut &
4361           *fac_shield(i)*fac_shield(j) &
4362           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4363 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4364 !          do l=1,3
4365 !            ggg(1)=(agg(1,1)*muij(1)+ &
4366 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
4367 !            *sss_ele_cut &
4368 !             +eel_loc_ij*sss_ele_grad*rmij*xj
4369 !            ggg(2)=(agg(2,1)*muij(1)+ &
4370 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
4371 !            *sss_ele_cut &
4372 !             +eel_loc_ij*sss_ele_grad*rmij*yj
4373 !            ggg(3)=(agg(3,1)*muij(1)+ &
4374 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
4375 !            *sss_ele_cut &
4376 !             +eel_loc_ij*sss_ele_grad*rmij*zj
4377            xtemp(1)=xj
4378            xtemp(2)=yj
4379            xtemp(3)=zj
4380
4381            do l=1,3
4382             ggg(l)=(agg(l,1)*muij(1)+ &
4383                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
4384             *sss_ele_cut &
4385           *fac_shield(i)*fac_shield(j) &
4386           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
4387              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4388
4389
4390             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4391             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4392 !grad            ghalf=0.5d0*ggg(l)
4393 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4394 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4395           enddo
4396             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
4397           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
4398           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4399
4400             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
4401           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
4402           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4403
4404 !grad          do k=i+1,j2
4405 !grad            do l=1,3
4406 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4407 !grad            enddo
4408 !grad          enddo
4409 ! Remaining derivatives of eello
4410           do l=1,3
4411             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4412                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(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,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4419                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4420             +aggi1(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             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4427                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4428             *sss_ele_cut &
4429           *fac_shield(i)*fac_shield(j) &
4430           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4431
4432 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4433             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4434                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4435             +aggj1(l,4)*muij(4))&
4436             *sss_ele_cut &
4437           *fac_shield(i)*fac_shield(j) &
4438          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4439
4440 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4441           enddo
4442           ENDIF
4443 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4444 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4445           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4446              .and. num_conti.le.maxconts) then
4447 !            write (iout,*) i,j," entered corr"
4448 !
4449 ! Calculate the contact function. The ith column of the array JCONT will
4450 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4451 ! greater than I). The arrays FACONT and GACONT will contain the values of
4452 ! the contact function and its derivative.
4453 !           r0ij=1.02D0*rpp(iteli,itelj)
4454 !           r0ij=1.11D0*rpp(iteli,itelj)
4455             r0ij=2.20D0*rpp(iteli,itelj)
4456 !           r0ij=1.55D0*rpp(iteli,itelj)
4457             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4458 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4459             if (fcont.gt.0.0D0) then
4460               num_conti=num_conti+1
4461               if (num_conti.gt.maxconts) then
4462 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4463 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4464                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4465                                ' will skip next contacts for this conf.', num_conti
4466               else
4467                 jcont_hb(num_conti,i)=j
4468 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4469 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4470                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4471                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4472 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4473 !  terms.
4474                 d_cont(num_conti,i)=rij
4475 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4476 !     --- Electrostatic-interaction matrix ---
4477                 a_chuj(1,1,num_conti,i)=a22
4478                 a_chuj(1,2,num_conti,i)=a23
4479                 a_chuj(2,1,num_conti,i)=a32
4480                 a_chuj(2,2,num_conti,i)=a33
4481 !     --- Gradient of rij
4482                 do kkk=1,3
4483                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4484                 enddo
4485                 kkll=0
4486                 do k=1,2
4487                   do l=1,2
4488                     kkll=kkll+1
4489                     do m=1,3
4490                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4491                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4492                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4493                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4494                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4495                     enddo
4496                   enddo
4497                 enddo
4498                 ENDIF
4499                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4500 ! Calculate contact energies
4501                 cosa4=4.0D0*cosa
4502                 wij=cosa-3.0D0*cosb*cosg
4503                 cosbg1=cosb+cosg
4504                 cosbg2=cosb-cosg
4505 !               fac3=dsqrt(-ael6i)/r0ij**3
4506                 fac3=dsqrt(-ael6i)*r3ij
4507 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4508                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4509                 if (ees0tmp.gt.0) then
4510                   ees0pij=dsqrt(ees0tmp)
4511                 else
4512                   ees0pij=0
4513                 endif
4514                 if (shield_mode.eq.0) then
4515                 fac_shield(i)=1.0d0
4516                 fac_shield(j)=1.0d0
4517                 else
4518                 ees0plist(num_conti,i)=j
4519                 endif
4520 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4521                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4522                 if (ees0tmp.gt.0) then
4523                   ees0mij=dsqrt(ees0tmp)
4524                 else
4525                   ees0mij=0
4526                 endif
4527 !               ees0mij=0.0D0
4528                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4529                      *sss_ele_cut &
4530                      *fac_shield(i)*fac_shield(j)
4531 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4532
4533                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4534                      *sss_ele_cut &
4535                      *fac_shield(i)*fac_shield(j)
4536 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4537
4538 ! Diagnostics. Comment out or remove after debugging!
4539 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4540 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4541 !               ees0m(num_conti,i)=0.0D0
4542 ! End diagnostics.
4543 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4544 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4545 ! Angular derivatives of the contact function
4546                 ees0pij1=fac3/ees0pij
4547                 ees0mij1=fac3/ees0mij
4548                 fac3p=-3.0D0*fac3*rrmij
4549                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4550                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4551 !               ees0mij1=0.0D0
4552                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4553                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4554                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4555                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4556                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4557                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4558                 ecosap=ecosa1+ecosa2
4559                 ecosbp=ecosb1+ecosb2
4560                 ecosgp=ecosg1+ecosg2
4561                 ecosam=ecosa1-ecosa2
4562                 ecosbm=ecosb1-ecosb2
4563                 ecosgm=ecosg1-ecosg2
4564 ! Diagnostics
4565 !               ecosap=ecosa1
4566 !               ecosbp=ecosb1
4567 !               ecosgp=ecosg1
4568 !               ecosam=0.0D0
4569 !               ecosbm=0.0D0
4570 !               ecosgm=0.0D0
4571 ! End diagnostics
4572                 facont_hb(num_conti,i)=fcont
4573                 fprimcont=fprimcont/rij
4574 !d              facont_hb(num_conti,i)=1.0D0
4575 ! Following line is for diagnostics.
4576 !d              fprimcont=0.0D0
4577                 do k=1,3
4578                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4579                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4580                 enddo
4581                 do k=1,3
4582                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4583                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4584                 enddo
4585                 gggp(1)=gggp(1)+ees0pijp*xj &
4586                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4587                 gggp(2)=gggp(2)+ees0pijp*yj &
4588                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4589                 gggp(3)=gggp(3)+ees0pijp*zj &
4590                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4591
4592                 gggm(1)=gggm(1)+ees0mijp*xj &
4593                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4594
4595                 gggm(2)=gggm(2)+ees0mijp*yj &
4596                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4597
4598                 gggm(3)=gggm(3)+ees0mijp*zj &
4599                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4600
4601 ! Derivatives due to the contact function
4602                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4603                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4604                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4605                 do k=1,3
4606 !
4607 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4608 !          following the change of gradient-summation algorithm.
4609 !
4610 !grad                  ghalfp=0.5D0*gggp(k)
4611 !grad                  ghalfm=0.5D0*gggm(k)
4612                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4613                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4614                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4615                      *sss_ele_cut*fac_shield(i)*fac_shield(j) ! &
4616 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4617
4618
4619                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4620                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4621                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4622                      *sss_ele_cut*fac_shield(i)*fac_shield(j)!   &
4623 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4624
4625
4626                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4627                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4628 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4629
4630                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4631                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4632                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4633                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4634 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4635
4636                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4637                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4638                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4639                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4640 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4641
4642                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4643                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4644 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4645
4646                 enddo
4647 ! Diagnostics. Comment out or remove after debugging!
4648 !diag           do k=1,3
4649 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4650 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4651 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4652 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4653 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4654 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4655 !diag           enddo
4656               ENDIF ! wcorr
4657               endif  ! num_conti.le.maxconts
4658             endif  ! fcont.gt.0
4659           endif    ! j.gt.i+1
4660           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4661             do k=1,4
4662               do l=1,3
4663                 ghalf=0.5d0*agg(l,k)
4664                 aggi(l,k)=aggi(l,k)+ghalf
4665                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4666                 aggj(l,k)=aggj(l,k)+ghalf
4667               enddo
4668             enddo
4669             if (j.eq.nres-1 .and. i.lt.j-2) then
4670               do k=1,4
4671                 do l=1,3
4672                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4673                 enddo
4674               enddo
4675             endif
4676           endif
4677  128  continue
4678 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4679       return
4680       end subroutine eelecij
4681 !-----------------------------------------------------------------------------
4682       subroutine eturn3(i,eello_turn3)
4683 ! Third- and fourth-order contributions from turns
4684
4685       use comm_locel
4686 !      implicit real*8 (a-h,o-z)
4687 !      include 'DIMENSIONS'
4688 !      include 'COMMON.IOUNITS'
4689 !      include 'COMMON.GEO'
4690 !      include 'COMMON.VAR'
4691 !      include 'COMMON.LOCAL'
4692 !      include 'COMMON.CHAIN'
4693 !      include 'COMMON.DERIV'
4694 !      include 'COMMON.INTERACT'
4695 !      include 'COMMON.CONTACTS'
4696 !      include 'COMMON.TORSION'
4697 !      include 'COMMON.VECTORS'
4698 !      include 'COMMON.FFIELD'
4699 !      include 'COMMON.CONTROL'
4700       real(kind=8),dimension(3) :: ggg
4701       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4702         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,gpizda1,&
4703        gpizda2,auxgmat1,auxgmatt1,auxgmat2,auxgmatt2
4704
4705       real(kind=8),dimension(2) :: auxvec,auxvec1
4706 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4707       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4708 !el      integer :: num_conti,j1,j2
4709 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4710 !el        dz_normi,xmedi,ymedi,zmedi
4711
4712 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4713 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4714 !el         num_conti,j1,j2
4715 !el local variables
4716       integer :: i,j,l,k,ilist,iresshield
4717       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield,xj,yj
4718       xj=0.0d0
4719       yj=0.0d0
4720       j=i+2
4721 !      write (iout,*) "eturn3",i,j,j1,j2
4722           zj=(c(3,j)+c(3,j+1))/2.0d0
4723             call to_box(xj,yj,zj)
4724             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
4725
4726       a_temp(1,1)=a22
4727       a_temp(1,2)=a23
4728       a_temp(2,1)=a32
4729       a_temp(2,2)=a33
4730 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4731 !
4732 !               Third-order contributions
4733 !
4734 !                 (i+2)o----(i+3)
4735 !                      | |
4736 !                      | |
4737 !                 (i+1)o----i
4738 !
4739 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4740 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4741         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4742         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4743         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4744         call transpose2(auxmat(1,1),auxmat1(1,1))
4745         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4746         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4747         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4748         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4749         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4750
4751         if (shield_mode.eq.0) then
4752         fac_shield(i)=1.0d0
4753         fac_shield(j)=1.0d0
4754         endif
4755
4756         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4757          *fac_shield(i)*fac_shield(j)  &
4758          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4759         eello_t3= &
4760         0.5d0*(pizda(1,1)+pizda(2,2)) &
4761         *fac_shield(i)*fac_shield(j)
4762
4763         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4764                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4765 !C#ifdef NEWCORR
4766 !C Derivatives in theta
4767         gloc(nphi+i,icg)=gloc(nphi+i,icg) &
4768        +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3&
4769         *fac_shield(i)*fac_shield(j) &
4770         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4771
4772         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)&
4773        +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3&
4774         *fac_shield(i)*fac_shield(j) &
4775         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4776
4777
4778 !C#endif
4779
4780
4781
4782           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4783        (shield_mode.gt.0)) then
4784 !C          print *,i,j
4785
4786           do ilist=1,ishield_list(i)
4787            iresshield=shield_list(ilist,i)
4788            do k=1,3
4789            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4790            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4791                    rlocshield &
4792            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4793             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4794              +rlocshield
4795            enddo
4796           enddo
4797           do ilist=1,ishield_list(j)
4798            iresshield=shield_list(ilist,j)
4799            do k=1,3
4800            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4801            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4802                    rlocshield &
4803            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4804            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4805                   +rlocshield
4806
4807            enddo
4808           enddo
4809
4810           do k=1,3
4811             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4812                    grad_shield(k,i)*eello_t3/fac_shield(i)
4813             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4814                    grad_shield(k,j)*eello_t3/fac_shield(j)
4815             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4816                    grad_shield(k,i)*eello_t3/fac_shield(i)
4817             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4818                    grad_shield(k,j)*eello_t3/fac_shield(j)
4819            enddo
4820            endif
4821
4822 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4823 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4824 !d     &    ' eello_turn3_num',4*eello_turn3_num
4825 ! Derivatives in gamma(i)
4826         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4827         call transpose2(auxmat2(1,1),auxmat3(1,1))
4828         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4829         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4830           *fac_shield(i)*fac_shield(j)        &
4831           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4832 ! Derivatives in gamma(i+1)
4833         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4834         call transpose2(auxmat2(1,1),auxmat3(1,1))
4835         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4836         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4837           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4838           *fac_shield(i)*fac_shield(j)        &
4839           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4840
4841 ! Cartesian derivatives
4842         do l=1,3
4843 !            ghalf1=0.5d0*agg(l,1)
4844 !            ghalf2=0.5d0*agg(l,2)
4845 !            ghalf3=0.5d0*agg(l,3)
4846 !            ghalf4=0.5d0*agg(l,4)
4847           a_temp(1,1)=aggi(l,1)!+ghalf1
4848           a_temp(1,2)=aggi(l,2)!+ghalf2
4849           a_temp(2,1)=aggi(l,3)!+ghalf3
4850           a_temp(2,2)=aggi(l,4)!+ghalf4
4851           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4852           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4853             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4854           *fac_shield(i)*fac_shield(j)      &
4855           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4856
4857           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4858           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4859           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4860           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4861           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4862           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4863             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4864           *fac_shield(i)*fac_shield(j)        &
4865           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4866
4867           a_temp(1,1)=aggj(l,1)!+ghalf1
4868           a_temp(1,2)=aggj(l,2)!+ghalf2
4869           a_temp(2,1)=aggj(l,3)!+ghalf3
4870           a_temp(2,2)=aggj(l,4)!+ghalf4
4871           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4872           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4873             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4874           *fac_shield(i)*fac_shield(j)      &
4875           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4876
4877           a_temp(1,1)=aggj1(l,1)
4878           a_temp(1,2)=aggj1(l,2)
4879           a_temp(2,1)=aggj1(l,3)
4880           a_temp(2,2)=aggj1(l,4)
4881           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4882           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4883             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4884           *fac_shield(i)*fac_shield(j)        &
4885           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4886         enddo
4887          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4888           ssgradlipi*eello_t3/4.0d0*lipscale
4889          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4890           ssgradlipj*eello_t3/4.0d0*lipscale
4891          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4892           ssgradlipi*eello_t3/4.0d0*lipscale
4893          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4894           ssgradlipj*eello_t3/4.0d0*lipscale
4895
4896       return
4897       end subroutine eturn3
4898 !-----------------------------------------------------------------------------
4899       subroutine eturn4(i,eello_turn4)
4900 ! Third- and fourth-order contributions from turns
4901
4902       use comm_locel
4903 !      implicit real*8 (a-h,o-z)
4904 !      include 'DIMENSIONS'
4905 !      include 'COMMON.IOUNITS'
4906 !      include 'COMMON.GEO'
4907 !      include 'COMMON.VAR'
4908 !      include 'COMMON.LOCAL'
4909 !      include 'COMMON.CHAIN'
4910 !      include 'COMMON.DERIV'
4911 !      include 'COMMON.INTERACT'
4912 !      include 'COMMON.CONTACTS'
4913 !      include 'COMMON.TORSION'
4914 !      include 'COMMON.VECTORS'
4915 !      include 'COMMON.FFIELD'
4916 !      include 'COMMON.CONTROL'
4917       real(kind=8),dimension(3) :: ggg
4918       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4919         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,&
4920         gte1t,gte2t,gte3t,&
4921         gte1a,gtae3,gtae3e2, ae3gte2,&
4922         gtEpizda1,gtEpizda2,gtEpizda3
4923
4924       real(kind=8),dimension(2) :: auxvec,auxvec1,auxgEvec1,auxgEvec2,&
4925        auxgEvec3,auxgvec
4926
4927 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4928       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4929 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4930 !el        dz_normi,xmedi,ymedi,zmedi
4931 !el      integer :: num_conti,j1,j2
4932 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4933 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4934 !el          num_conti,j1,j2
4935 !el local variables
4936       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4937       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4938          rlocshield,gs23,gs32,gsE13,gs13,gs21,gsE31,gsEE1,gsEE2,gsEE3,xj,yj
4939       xj=0.0d0
4940       yj=0.0d0
4941       j=i+3
4942 !      if (j.ne.20) return
4943 !      print *,i,j,gshieldc_t4(2,j),gshieldc_t4(2,j+1)
4944 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4945 !
4946 !               Fourth-order contributions
4947 !
4948 !                 (i+3)o----(i+4)
4949 !                     /  |
4950 !               (i+2)o   |
4951 !                     \  |
4952 !                 (i+1)o----i
4953 !
4954 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4955 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4956 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4957           zj=(c(3,j)+c(3,j+1))/2.0d0
4958             call to_box(xj,yj,zj)
4959             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
4960
4961
4962         a_temp(1,1)=a22
4963         a_temp(1,2)=a23
4964         a_temp(2,1)=a32
4965         a_temp(2,2)=a33
4966         iti1=i+1
4967         iti2=i+2
4968         iti3=i+3
4969 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4970         call transpose2(EUg(1,1,i+1),e1t(1,1))
4971         call transpose2(Eug(1,1,i+2),e2t(1,1))
4972         call transpose2(Eug(1,1,i+3),e3t(1,1))
4973 !C Ematrix derivative in theta
4974         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4975         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4976         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4977
4978         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4979         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4980         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4981         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4982 !c       auxalary matrix of E i+1
4983         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4984         s1=scalar2(b1(1,iti2),auxvec(1))
4985 !c derivative of theta i+2 with constant i+3
4986         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4987 !c derivative of theta i+2 with constant i+2
4988         gs32=scalar2(b1(1,i+2),auxgvec(1))
4989 !c derivative of E matix in theta of i+1
4990         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4991
4992         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4993         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4994         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4995 !c auxilary matrix auxgvec of Ub2 with constant E matirx
4996         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4997 !c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4998         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4999         s2=scalar2(b1(1,i+1),auxvec(1))
5000 !c derivative of theta i+1 with constant i+3
5001         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5002 !c derivative of theta i+2 with constant i+1
5003         gs21=scalar2(b1(1,i+1),auxgvec(1))
5004 !c derivative of theta i+3 with constant i+1
5005         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5006
5007         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5008         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5009 !c ae3gte2 is derivative over i+2
5010         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5011
5012         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5013         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5014 !c i+2
5015         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5016 !c i+3
5017         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5018
5019         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5020         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5021         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5022         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5023         if (shield_mode.eq.0) then
5024         fac_shield(i)=1.0
5025         fac_shield(j)=1.0
5026         endif
5027
5028         eello_turn4=eello_turn4-(s1+s2+s3) &
5029         *fac_shield(i)*fac_shield(j)       &
5030         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5031         eello_t4=-(s1+s2+s3)  &
5032           *fac_shield(i)*fac_shield(j)
5033 !C Now derivative over shield:
5034           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
5035          (shield_mode.gt.0)) then
5036 !C          print *,i,j
5037
5038           do ilist=1,ishield_list(i)
5039            iresshield=shield_list(ilist,i)
5040            do k=1,3
5041            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5042 !           print *,"rlocshield",rlocshield,grad_shield_side(k,ilist,i),iresshield
5043            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5044                    rlocshield &
5045             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5046             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5047            +rlocshield
5048            enddo
5049           enddo
5050           do ilist=1,ishield_list(j)
5051            iresshield=shield_list(ilist,j)
5052            do k=1,3
5053 !           print *,"rlocshieldj",j,rlocshield,grad_shield_side(k,ilist,j),iresshield
5054            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5055            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5056                    rlocshield  &
5057            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5058            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5059                   +rlocshield
5060 !            print *,"after", gshieldc_t4(k,iresshield-1),iresshield-1,gshieldc_t4(k,iresshield)
5061
5062            enddo
5063           enddo
5064           do k=1,3
5065             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
5066                    grad_shield(k,i)*eello_t4/fac_shield(i)
5067             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
5068                    grad_shield(k,j)*eello_t4/fac_shield(j)
5069             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
5070                    grad_shield(k,i)*eello_t4/fac_shield(i)
5071             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
5072                    grad_shield(k,j)*eello_t4/fac_shield(j)
5073 !           print *,"gshieldc_t4(k,j+1)",j,gshieldc_t4(k,j+1)
5074            enddo
5075            endif
5076 #ifdef NEWCORR
5077         gloc(nphi+i,icg)=gloc(nphi+i,icg)&
5078                        -(gs13+gsE13+gsEE1)*wturn4&
5079        *fac_shield(i)*fac_shield(j)
5080         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)&
5081                          -(gs23+gs21+gsEE2)*wturn4&
5082        *fac_shield(i)*fac_shield(j)
5083
5084         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)&
5085                          -(gs32+gsE31+gsEE3)*wturn4&
5086        *fac_shield(i)*fac_shield(j)
5087
5088 !c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5089 !c     &   gs2
5090 #endif
5091         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5092            'eturn4',i,j,-(s1+s2+s3)
5093 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5094 !d     &    ' eello_turn4_num',8*eello_turn4_num
5095 ! Derivatives in gamma(i)
5096         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5097         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5098         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5099         s1=scalar2(b1(1,i+1),auxvec(1))
5100         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5101         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5102         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
5103        *fac_shield(i)*fac_shield(j)  &
5104        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5105
5106 ! Derivatives in gamma(i+1)
5107         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5108         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5109         s2=scalar2(b1(1,iti1),auxvec(1))
5110         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5111         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5112         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5113         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
5114        *fac_shield(i)*fac_shield(j)  &
5115        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5116
5117 ! Derivatives in gamma(i+2)
5118         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5119         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5120         s1=scalar2(b1(1,iti2),auxvec(1))
5121         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5122         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5123         s2=scalar2(b1(1,iti1),auxvec(1))
5124         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5125         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5126         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5127         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
5128        *fac_shield(i)*fac_shield(j)  &
5129        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5130
5131 ! Cartesian derivatives
5132 ! Derivatives of this turn contributions in DC(i+2)
5133         if (j.lt.nres-1) then
5134           do l=1,3
5135             a_temp(1,1)=agg(l,1)
5136             a_temp(1,2)=agg(l,2)
5137             a_temp(2,1)=agg(l,3)
5138             a_temp(2,2)=agg(l,4)
5139             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5140             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5141             s1=scalar2(b1(1,iti2),auxvec(1))
5142             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5143             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5144             s2=scalar2(b1(1,iti1),auxvec(1))
5145             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5146             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5147             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5148             ggg(l)=-(s1+s2+s3)
5149             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
5150        *fac_shield(i)*fac_shield(j)  &
5151        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5152
5153           enddo
5154         endif
5155 ! Remaining derivatives of this turn contribution
5156         do l=1,3
5157           a_temp(1,1)=aggi(l,1)
5158           a_temp(1,2)=aggi(l,2)
5159           a_temp(2,1)=aggi(l,3)
5160           a_temp(2,2)=aggi(l,4)
5161           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5162           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5163           s1=scalar2(b1(1,iti2),auxvec(1))
5164           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5165           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5166           s2=scalar2(b1(1,iti1),auxvec(1))
5167           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5168           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5169           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5170           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
5171          *fac_shield(i)*fac_shield(j)  &
5172          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5173
5174
5175           a_temp(1,1)=aggi1(l,1)
5176           a_temp(1,2)=aggi1(l,2)
5177           a_temp(2,1)=aggi1(l,3)
5178           a_temp(2,2)=aggi1(l,4)
5179           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5180           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5181           s1=scalar2(b1(1,iti2),auxvec(1))
5182           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5183           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5184           s2=scalar2(b1(1,iti1),auxvec(1))
5185           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5186           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5187           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5188           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
5189          *fac_shield(i)*fac_shield(j)  &
5190          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5191
5192
5193           a_temp(1,1)=aggj(l,1)
5194           a_temp(1,2)=aggj(l,2)
5195           a_temp(2,1)=aggj(l,3)
5196           a_temp(2,2)=aggj(l,4)
5197           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5198           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5199           s1=scalar2(b1(1,iti2),auxvec(1))
5200           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5201           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5202           s2=scalar2(b1(1,iti1),auxvec(1))
5203           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5204           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5205           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5206 !        if (j.lt.nres-1) then
5207           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
5208          *fac_shield(i)*fac_shield(j)  &
5209          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5210 !        endif
5211
5212           a_temp(1,1)=aggj1(l,1)
5213           a_temp(1,2)=aggj1(l,2)
5214           a_temp(2,1)=aggj1(l,3)
5215           a_temp(2,2)=aggj1(l,4)
5216           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5217           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5218           s1=scalar2(b1(1,iti2),auxvec(1))
5219           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5220           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5221           s2=scalar2(b1(1,iti1),auxvec(1))
5222           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5223           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5224           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5225 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5226 !        if (j.lt.nres-1) then
5227 !          print *,"juest before",j1, gcorr4_turn(l,j1)
5228           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
5229          *fac_shield(i)*fac_shield(j)  &
5230          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5231 !            if (shield_mode.gt.0) then
5232 !             print *,"juest after",j1, gcorr4_turn(l,j1),gshieldc_t4(k,j1),gshieldc_loc_t4(k,j1),gel_loc_turn4(i+2)
5233 !            else
5234 !             print *,"juest after",j1, gcorr4_turn(l,j1),gel_loc_turn4(i+2)
5235 !            endif
5236 !         endif
5237         enddo
5238          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
5239           ssgradlipi*eello_t4/4.0d0*lipscale
5240          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
5241           ssgradlipj*eello_t4/4.0d0*lipscale
5242          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
5243           ssgradlipi*eello_t4/4.0d0*lipscale
5244          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
5245           ssgradlipj*eello_t4/4.0d0*lipscale
5246
5247       return
5248       end subroutine eturn4
5249 !-----------------------------------------------------------------------------
5250       subroutine unormderiv(u,ugrad,unorm,ungrad)
5251 ! This subroutine computes the derivatives of a normalized vector u, given
5252 ! the derivatives computed without normalization conditions, ugrad. Returns
5253 ! ungrad.
5254 !      implicit none
5255       real(kind=8),dimension(3) :: u,vec
5256       real(kind=8),dimension(3,3) ::ugrad,ungrad
5257       real(kind=8) :: unorm      !,scalar
5258       integer :: i,j
5259 !      write (2,*) 'ugrad',ugrad
5260 !      write (2,*) 'u',u
5261       do i=1,3
5262         vec(i)=scalar(ugrad(1,i),u(1))
5263       enddo
5264 !      write (2,*) 'vec',vec
5265       do i=1,3
5266         do j=1,3
5267           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5268         enddo
5269       enddo
5270 !      write (2,*) 'ungrad',ungrad
5271       return
5272       end subroutine unormderiv
5273 !-----------------------------------------------------------------------------
5274       subroutine escp_soft_sphere(evdw2,evdw2_14)
5275 !
5276 ! This subroutine calculates the excluded-volume interaction energy between
5277 ! peptide-group centers and side chains and its gradient in virtual-bond and
5278 ! side-chain vectors.
5279 !
5280 !      implicit real*8 (a-h,o-z)
5281 !      include 'DIMENSIONS'
5282 !      include 'COMMON.GEO'
5283 !      include 'COMMON.VAR'
5284 !      include 'COMMON.LOCAL'
5285 !      include 'COMMON.CHAIN'
5286 !      include 'COMMON.DERIV'
5287 !      include 'COMMON.INTERACT'
5288 !      include 'COMMON.FFIELD'
5289 !      include 'COMMON.IOUNITS'
5290 !      include 'COMMON.CONTROL'
5291       real(kind=8),dimension(3) :: ggg
5292 !el local variables
5293       integer :: i,iint,j,k,iteli,itypj
5294       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
5295                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
5296
5297       evdw2=0.0D0
5298       evdw2_14=0.0d0
5299       r0_scp=4.5d0
5300 !d    print '(a)','Enter ESCP'
5301 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5302       do i=iatscp_s,iatscp_e
5303         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5304         iteli=itel(i)
5305         xi=0.5D0*(c(1,i)+c(1,i+1))
5306         yi=0.5D0*(c(2,i)+c(2,i+1))
5307         zi=0.5D0*(c(3,i)+c(3,i+1))
5308           call to_box(xi,yi,zi)
5309
5310         do iint=1,nscp_gr(i)
5311
5312         do j=iscpstart(i,iint),iscpend(i,iint)
5313           if (itype(j,1).eq.ntyp1) cycle
5314           itypj=iabs(itype(j,1))
5315 ! Uncomment following three lines for SC-p interactions
5316 !         xj=c(1,nres+j)-xi
5317 !         yj=c(2,nres+j)-yi
5318 !         zj=c(3,nres+j)-zi
5319 ! Uncomment following three lines for Ca-p interactions
5320           xj=c(1,j)-xi
5321           yj=c(2,j)-yi
5322           zj=c(3,j)-zi
5323           call to_box(xj,yj,zj)
5324           xj=boxshift(xj-xi,boxxsize)
5325           yj=boxshift(yj-yi,boxysize)
5326           zj=boxshift(zj-zi,boxzsize)
5327           rij=xj*xj+yj*yj+zj*zj
5328           r0ij=r0_scp
5329           r0ijsq=r0ij*r0ij
5330           if (rij.lt.r0ijsq) then
5331             evdwij=0.25d0*(rij-r0ijsq)**2
5332             fac=rij-r0ijsq
5333           else
5334             evdwij=0.0d0
5335             fac=0.0d0
5336           endif
5337           evdw2=evdw2+evdwij
5338 !
5339 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5340 !
5341           ggg(1)=xj*fac
5342           ggg(2)=yj*fac
5343           ggg(3)=zj*fac
5344 !grad          if (j.lt.i) then
5345 !d          write (iout,*) 'j<i'
5346 ! Uncomment following three lines for SC-p interactions
5347 !           do k=1,3
5348 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5349 !           enddo
5350 !grad          else
5351 !d          write (iout,*) 'j>i'
5352 !grad            do k=1,3
5353 !grad              ggg(k)=-ggg(k)
5354 ! Uncomment following line for SC-p interactions
5355 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5356 !grad            enddo
5357 !grad          endif
5358 !grad          do k=1,3
5359 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5360 !grad          enddo
5361 !grad          kstart=min0(i+1,j)
5362 !grad          kend=max0(i-1,j-1)
5363 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5364 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5365 !grad          do k=kstart,kend
5366 !grad            do l=1,3
5367 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5368 !grad            enddo
5369 !grad          enddo
5370           do k=1,3
5371             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5372             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5373           enddo
5374         enddo
5375
5376         enddo ! iint
5377       enddo ! i
5378       return
5379       end subroutine escp_soft_sphere
5380 !-----------------------------------------------------------------------------
5381       subroutine escp(evdw2,evdw2_14)
5382 !
5383 ! This subroutine calculates the excluded-volume interaction energy between
5384 ! peptide-group centers and side chains and its gradient in virtual-bond and
5385 ! side-chain vectors.
5386 !
5387 !      implicit real*8 (a-h,o-z)
5388 !      include 'DIMENSIONS'
5389 !      include 'COMMON.GEO'
5390 !      include 'COMMON.VAR'
5391 !      include 'COMMON.LOCAL'
5392 !      include 'COMMON.CHAIN'
5393 !      include 'COMMON.DERIV'
5394 !      include 'COMMON.INTERACT'
5395 !      include 'COMMON.FFIELD'
5396 !      include 'COMMON.IOUNITS'
5397 !      include 'COMMON.CONTROL'
5398       real(kind=8),dimension(3) :: ggg
5399 !el local variables
5400       integer :: i,iint,j,k,iteli,itypj,subchap,icont
5401       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
5402                    e1,e2,evdwij,rij
5403       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
5404                     dist_temp, dist_init
5405       integer xshift,yshift,zshift
5406
5407       evdw2=0.0D0
5408       evdw2_14=0.0d0
5409 !d    print '(a)','Enter ESCP'
5410 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5411 !      do i=iatscp_s,iatscp_e
5412        do icont=g_listscp_start,g_listscp_end
5413         i=newcontlistscpi(icont)
5414         j=newcontlistscpj(icont)
5415         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5416         iteli=itel(i)
5417         xi=0.5D0*(c(1,i)+c(1,i+1))
5418         yi=0.5D0*(c(2,i)+c(2,i+1))
5419         zi=0.5D0*(c(3,i)+c(3,i+1))
5420         call to_box(xi,yi,zi)
5421
5422 !        do iint=1,nscp_gr(i)
5423
5424 !        do j=iscpstart(i,iint),iscpend(i,iint)
5425           itypj=iabs(itype(j,1))
5426           if (itypj.eq.ntyp1) cycle
5427 ! Uncomment following three lines for SC-p interactions
5428 !         xj=c(1,nres+j)-xi
5429 !         yj=c(2,nres+j)-yi
5430 !         zj=c(3,nres+j)-zi
5431 ! Uncomment following three lines for Ca-p interactions
5432 !          xj=c(1,j)-xi
5433 !          yj=c(2,j)-yi
5434 !          zj=c(3,j)-zi
5435           xj=c(1,j)
5436           yj=c(2,j)
5437           zj=c(3,j)
5438
5439           call to_box(xj,yj,zj)
5440           xj=boxshift(xj-xi,boxxsize)
5441           yj=boxshift(yj-yi,boxysize)
5442           zj=boxshift(zj-zi,boxzsize)
5443
5444           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5445           rij=dsqrt(1.0d0/rrij)
5446             sss_ele_cut=sscale_ele(rij)
5447             sss_ele_grad=sscagrad_ele(rij)
5448 !            print *,sss_ele_cut,sss_ele_grad,&
5449 !            (rij),r_cut_ele,rlamb_ele
5450             if (sss_ele_cut.le.0.0) cycle
5451           fac=rrij**expon2
5452           e1=fac*fac*aad(itypj,iteli)
5453           e2=fac*bad(itypj,iteli)
5454           if (iabs(j-i) .le. 2) then
5455             e1=scal14*e1
5456             e2=scal14*e2
5457             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5458           endif
5459           evdwij=e1+e2
5460           evdw2=evdw2+evdwij*sss_ele_cut
5461 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5462 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5463           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5464              'evdw2',i,j,evdwij
5465 !
5466 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5467 !
5468           fac=-(evdwij+e1)*rrij*sss_ele_cut
5469           fac=fac+evdwij*sss_ele_grad/rij/expon
5470           ggg(1)=xj*fac
5471           ggg(2)=yj*fac
5472           ggg(3)=zj*fac
5473 !grad          if (j.lt.i) then
5474 !d          write (iout,*) 'j<i'
5475 ! Uncomment following three lines for SC-p interactions
5476 !           do k=1,3
5477 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5478 !           enddo
5479 !grad          else
5480 !d          write (iout,*) 'j>i'
5481 !grad            do k=1,3
5482 !grad              ggg(k)=-ggg(k)
5483 ! Uncomment following line for SC-p interactions
5484 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5485 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5486 !grad            enddo
5487 !grad          endif
5488 !grad          do k=1,3
5489 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5490 !grad          enddo
5491 !grad          kstart=min0(i+1,j)
5492 !grad          kend=max0(i-1,j-1)
5493 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5494 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5495 !grad          do k=kstart,kend
5496 !grad            do l=1,3
5497 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5498 !grad            enddo
5499 !grad          enddo
5500           do k=1,3
5501             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5502             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5503           enddo
5504 !        enddo
5505
5506 !        enddo ! iint
5507       enddo ! i
5508       do i=1,nct
5509         do j=1,3
5510           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5511           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5512           gradx_scp(j,i)=expon*gradx_scp(j,i)
5513         enddo
5514       enddo
5515 !******************************************************************************
5516 !
5517 !                              N O T E !!!
5518 !
5519 ! To save time the factor EXPON has been extracted from ALL components
5520 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5521 ! use!
5522 !
5523 !******************************************************************************
5524       return
5525       end subroutine escp
5526 !-----------------------------------------------------------------------------
5527       subroutine edis(ehpb)
5528 !
5529 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5530 !
5531 !      implicit real*8 (a-h,o-z)
5532 !      include 'DIMENSIONS'
5533 !      include 'COMMON.SBRIDGE'
5534 !      include 'COMMON.CHAIN'
5535 !      include 'COMMON.DERIV'
5536 !      include 'COMMON.VAR'
5537 !      include 'COMMON.INTERACT'
5538 !      include 'COMMON.IOUNITS'
5539       real(kind=8),dimension(3) :: ggg
5540 !el local variables
5541       integer :: i,j,ii,jj,iii,jjj,k
5542       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5543
5544       ehpb=0.0D0
5545 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5546 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5547       if (link_end.eq.0) return
5548       do i=link_start,link_end
5549 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5550 ! CA-CA distance used in regularization of structure.
5551         ii=ihpb(i)
5552         jj=jhpb(i)
5553 ! iii and jjj point to the residues for which the distance is assigned.
5554         if (ii.gt.nres) then
5555           iii=ii-nres
5556           jjj=jj-nres
5557         else
5558           iii=ii
5559           jjj=jj
5560         endif
5561 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5562 !     &    dhpb(i),dhpb1(i),forcon(i)
5563 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5564 !    distance and angle dependent SS bond potential.
5565 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5566 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5567         if (.not.dyn_ss .and. i.le.nss) then
5568 ! 15/02/13 CC dynamic SSbond - additional check
5569          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5570         iabs(itype(jjj,1)).eq.1) then
5571           call ssbond_ene(iii,jjj,eij)
5572           ehpb=ehpb+2*eij
5573 !d          write (iout,*) "eij",eij
5574          endif
5575         else if (ii.gt.nres .and. jj.gt.nres) then
5576 !c Restraints from contact prediction
5577           dd=dist(ii,jj)
5578           if (constr_dist.eq.11) then
5579             ehpb=ehpb+fordepth(i)**4.0d0 &
5580                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5581             fac=fordepth(i)**4.0d0 &
5582                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5583           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5584             ehpb,fordepth(i),dd
5585            else
5586           if (dhpb1(i).gt.0.0d0) then
5587             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5588             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5589 !c            write (iout,*) "beta nmr",
5590 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5591           else
5592             dd=dist(ii,jj)
5593             rdis=dd-dhpb(i)
5594 !C Get the force constant corresponding to this distance.
5595             waga=forcon(i)
5596 !C Calculate the contribution to energy.
5597             ehpb=ehpb+waga*rdis*rdis
5598 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5599 !C
5600 !C Evaluate gradient.
5601 !C
5602             fac=waga*rdis/dd
5603           endif
5604           endif
5605           do j=1,3
5606             ggg(j)=fac*(c(j,jj)-c(j,ii))
5607           enddo
5608           do j=1,3
5609             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5610             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5611           enddo
5612           do k=1,3
5613             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5614             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5615           enddo
5616         else
5617           dd=dist(ii,jj)
5618           if (constr_dist.eq.11) then
5619             ehpb=ehpb+fordepth(i)**4.0d0 &
5620                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5621             fac=fordepth(i)**4.0d0 &
5622                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5623           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5624          ehpb,fordepth(i),dd
5625            else
5626           if (dhpb1(i).gt.0.0d0) then
5627             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5628             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5629 !c            write (iout,*) "alph nmr",
5630 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5631           else
5632             rdis=dd-dhpb(i)
5633 !C Get the force constant corresponding to this distance.
5634             waga=forcon(i)
5635 !C Calculate the contribution to energy.
5636             ehpb=ehpb+waga*rdis*rdis
5637 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5638 !C
5639 !C Evaluate gradient.
5640 !C
5641             fac=waga*rdis/dd
5642           endif
5643           endif
5644
5645             do j=1,3
5646               ggg(j)=fac*(c(j,jj)-c(j,ii))
5647             enddo
5648 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5649 !C If this is a SC-SC distance, we need to calculate the contributions to the
5650 !C Cartesian gradient in the SC vectors (ghpbx).
5651           if (iii.lt.ii) then
5652           do j=1,3
5653             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5654             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5655           enddo
5656           endif
5657 !cgrad        do j=iii,jjj-1
5658 !cgrad          do k=1,3
5659 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5660 !cgrad          enddo
5661 !cgrad        enddo
5662           do k=1,3
5663             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5664             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5665           enddo
5666         endif
5667       enddo
5668       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5669
5670       return
5671       end subroutine edis
5672 !-----------------------------------------------------------------------------
5673       subroutine ssbond_ene(i,j,eij)
5674 !
5675 ! Calculate the distance and angle dependent SS-bond potential energy
5676 ! using a free-energy function derived based on RHF/6-31G** ab initio
5677 ! calculations of diethyl disulfide.
5678 !
5679 ! A. Liwo and U. Kozlowska, 11/24/03
5680 !
5681 !      implicit real*8 (a-h,o-z)
5682 !      include 'DIMENSIONS'
5683 !      include 'COMMON.SBRIDGE'
5684 !      include 'COMMON.CHAIN'
5685 !      include 'COMMON.DERIV'
5686 !      include 'COMMON.LOCAL'
5687 !      include 'COMMON.INTERACT'
5688 !      include 'COMMON.VAR'
5689 !      include 'COMMON.IOUNITS'
5690       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5691 !el local variables
5692       integer :: i,j,itypi,itypj,k
5693       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5694                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5695                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5696                    cosphi,ggk
5697
5698       itypi=iabs(itype(i,1))
5699       xi=c(1,nres+i)
5700       yi=c(2,nres+i)
5701       zi=c(3,nres+i)
5702           call to_box(xi,yi,zi)
5703
5704       dxi=dc_norm(1,nres+i)
5705       dyi=dc_norm(2,nres+i)
5706       dzi=dc_norm(3,nres+i)
5707 !      dsci_inv=dsc_inv(itypi)
5708       dsci_inv=vbld_inv(nres+i)
5709       itypj=iabs(itype(j,1))
5710 !      dscj_inv=dsc_inv(itypj)
5711       dscj_inv=vbld_inv(nres+j)
5712       xj=c(1,nres+j)-xi
5713       yj=c(2,nres+j)-yi
5714       zj=c(3,nres+j)-zi
5715           call to_box(xj,yj,zj)
5716       dxj=dc_norm(1,nres+j)
5717       dyj=dc_norm(2,nres+j)
5718       dzj=dc_norm(3,nres+j)
5719       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5720       rij=dsqrt(rrij)
5721       erij(1)=xj*rij
5722       erij(2)=yj*rij
5723       erij(3)=zj*rij
5724       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5725       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5726       om12=dxi*dxj+dyi*dyj+dzi*dzj
5727       do k=1,3
5728         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5729         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5730       enddo
5731       rij=1.0d0/rij
5732       deltad=rij-d0cm
5733       deltat1=1.0d0-om1
5734       deltat2=1.0d0+om2
5735       deltat12=om2-om1+2.0d0
5736       cosphi=om12-om1*om2
5737       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5738         +akct*deltad*deltat12 &
5739         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5740 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5741 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5742 !     &  " deltat12",deltat12," eij",eij
5743       ed=2*akcm*deltad+akct*deltat12
5744       pom1=akct*deltad
5745       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5746       eom1=-2*akth*deltat1-pom1-om2*pom2
5747       eom2= 2*akth*deltat2+pom1-om1*pom2
5748       eom12=pom2
5749       do k=1,3
5750         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5751         ghpbx(k,i)=ghpbx(k,i)-ggk &
5752                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5753                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5754         ghpbx(k,j)=ghpbx(k,j)+ggk &
5755                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5756                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5757         ghpbc(k,i)=ghpbc(k,i)-ggk
5758         ghpbc(k,j)=ghpbc(k,j)+ggk
5759       enddo
5760 !
5761 ! Calculate the components of the gradient in DC and X
5762 !
5763 !grad      do k=i,j-1
5764 !grad        do l=1,3
5765 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5766 !grad        enddo
5767 !grad      enddo
5768       return
5769       end subroutine ssbond_ene
5770 !-----------------------------------------------------------------------------
5771       subroutine ebond(estr)
5772 !
5773 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5774 !
5775 !      implicit real*8 (a-h,o-z)
5776 !      include 'DIMENSIONS'
5777 !      include 'COMMON.LOCAL'
5778 !      include 'COMMON.GEO'
5779 !      include 'COMMON.INTERACT'
5780 !      include 'COMMON.DERIV'
5781 !      include 'COMMON.VAR'
5782 !      include 'COMMON.CHAIN'
5783 !      include 'COMMON.IOUNITS'
5784 !      include 'COMMON.NAMES'
5785 !      include 'COMMON.FFIELD'
5786 !      include 'COMMON.CONTROL'
5787 !      include 'COMMON.SETUP'
5788       real(kind=8),dimension(3) :: u,ud
5789 !el local variables
5790       integer :: i,j,iti,nbi,k
5791       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5792                    uprod1,uprod2
5793
5794       estr=0.0d0
5795       estr1=0.0d0
5796 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5797 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5798
5799       do i=ibondp_start,ibondp_end
5800         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5801         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5802 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5803 !C          do j=1,3
5804 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5805 !C            *dc(j,i-1)/vbld(i)
5806 !C          enddo
5807 !C          if (energy_dec) write(iout,*) &
5808 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5809         diff = vbld(i)-vbldpDUM
5810         else
5811         diff = vbld(i)-vbldp0
5812         endif
5813         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5814            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5815         estr=estr+diff*diff
5816         do j=1,3
5817           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5818         enddo
5819 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5820 !        endif
5821       enddo
5822       estr=0.5d0*AKP*estr+estr1
5823 !      print *,"estr_bb",estr,AKP
5824 !
5825 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5826 !
5827       do i=ibond_start,ibond_end
5828         iti=iabs(itype(i,1))
5829         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5830         if (iti.ne.10 .and. iti.ne.ntyp1) then
5831           nbi=nbondterm(iti)
5832           if (nbi.eq.1) then
5833             diff=vbld(i+nres)-vbldsc0(1,iti)
5834             if (energy_dec) write (iout,*) &
5835             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5836             AKSC(1,iti),AKSC(1,iti)*diff*diff
5837             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5838 !            print *,"estr_sc",estr
5839             do j=1,3
5840               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5841             enddo
5842           else
5843             do j=1,nbi
5844               diff=vbld(i+nres)-vbldsc0(j,iti)
5845               ud(j)=aksc(j,iti)*diff
5846               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5847             enddo
5848             uprod=u(1)
5849             do j=2,nbi
5850               uprod=uprod*u(j)
5851             enddo
5852             usum=0.0d0
5853             usumsqder=0.0d0
5854             do j=1,nbi
5855               uprod1=1.0d0
5856               uprod2=1.0d0
5857               do k=1,nbi
5858                 if (k.ne.j) then
5859                   uprod1=uprod1*u(k)
5860                   uprod2=uprod2*u(k)*u(k)
5861                 endif
5862               enddo
5863               usum=usum+uprod1
5864               usumsqder=usumsqder+ud(j)*uprod2
5865             enddo
5866             estr=estr+uprod/usum
5867 !            print *,"estr_sc",estr,i
5868
5869              if (energy_dec) write (iout,*) &
5870             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5871             AKSC(1,iti),uprod/usum
5872             do j=1,3
5873              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5874             enddo
5875           endif
5876         endif
5877       enddo
5878       return
5879       end subroutine ebond
5880 #ifdef CRYST_THETA
5881 !-----------------------------------------------------------------------------
5882       subroutine ebend(etheta)
5883 !
5884 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5885 ! angles gamma and its derivatives in consecutive thetas and gammas.
5886 !
5887       use comm_calcthet
5888 !      implicit real*8 (a-h,o-z)
5889 !      include 'DIMENSIONS'
5890 !      include 'COMMON.LOCAL'
5891 !      include 'COMMON.GEO'
5892 !      include 'COMMON.INTERACT'
5893 !      include 'COMMON.DERIV'
5894 !      include 'COMMON.VAR'
5895 !      include 'COMMON.CHAIN'
5896 !      include 'COMMON.IOUNITS'
5897 !      include 'COMMON.NAMES'
5898 !      include 'COMMON.FFIELD'
5899 !      include 'COMMON.CONTROL'
5900 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5901 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5902 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5903 !el      integer :: it
5904 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5905 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5906 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5907 !el local variables
5908       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5909        ichir21,ichir22
5910       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5911        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5912        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5913       real(kind=8),dimension(2) :: y,z
5914
5915       delta=0.02d0*pi
5916 !      time11=dexp(-2*time)
5917 !      time12=1.0d0
5918       etheta=0.0D0
5919 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5920       do i=ithet_start,ithet_end
5921         if (itype(i-1,1).eq.ntyp1) cycle
5922 ! Zero the energy function and its derivative at 0 or pi.
5923         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5924         it=itype(i-1,1)
5925         ichir1=isign(1,itype(i-2,1))
5926         ichir2=isign(1,itype(i,1))
5927          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
5928          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
5929          if (itype(i-1,1).eq.10) then
5930           itype1=isign(10,itype(i-2,1))
5931           ichir11=isign(1,itype(i-2,1))
5932           ichir12=isign(1,itype(i-2,1))
5933           itype2=isign(10,itype(i,1))
5934           ichir21=isign(1,itype(i,1))
5935           ichir22=isign(1,itype(i,1))
5936          endif
5937
5938         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
5939 #ifdef OSF
5940           phii=phi(i)
5941           if (phii.ne.phii) phii=150.0
5942 #else
5943           phii=phi(i)
5944 #endif
5945           y(1)=dcos(phii)
5946           y(2)=dsin(phii)
5947         else
5948           y(1)=0.0D0
5949           y(2)=0.0D0
5950         endif
5951         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
5952 #ifdef OSF
5953           phii1=phi(i+1)
5954           if (phii1.ne.phii1) phii1=150.0
5955           phii1=pinorm(phii1)
5956           z(1)=cos(phii1)
5957 #else
5958           phii1=phi(i+1)
5959           z(1)=dcos(phii1)
5960 #endif
5961           z(2)=dsin(phii1)
5962         else
5963           z(1)=0.0D0
5964           z(2)=0.0D0
5965         endif
5966 ! Calculate the "mean" value of theta from the part of the distribution
5967 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5968 ! In following comments this theta will be referred to as t_c.
5969         thet_pred_mean=0.0d0
5970         do k=1,2
5971             athetk=athet(k,it,ichir1,ichir2)
5972             bthetk=bthet(k,it,ichir1,ichir2)
5973           if (it.eq.10) then
5974              athetk=athet(k,itype1,ichir11,ichir12)
5975              bthetk=bthet(k,itype2,ichir21,ichir22)
5976           endif
5977          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5978         enddo
5979         dthett=thet_pred_mean*ssd
5980         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5981 ! Derivatives of the "mean" values in gamma1 and gamma2.
5982         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5983                +athet(2,it,ichir1,ichir2)*y(1))*ss
5984         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5985                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5986          if (it.eq.10) then
5987         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5988              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5989         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5990                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5991          endif
5992         if (theta(i).gt.pi-delta) then
5993           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5994                E_tc0)
5995           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5996           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5997           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5998               E_theta)
5999           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
6000               E_tc)
6001         else if (theta(i).lt.delta) then
6002           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6003           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6004           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
6005               E_theta)
6006           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6007           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
6008               E_tc)
6009         else
6010           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
6011               E_theta,E_tc)
6012         endif
6013         etheta=etheta+ethetai
6014         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6015             'ebend',i,ethetai
6016         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6017         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6018         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
6019       enddo
6020 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6021
6022 ! Ufff.... We've done all this!!!
6023       return
6024       end subroutine ebend
6025 !-----------------------------------------------------------------------------
6026       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
6027
6028       use comm_calcthet
6029 !      implicit real*8 (a-h,o-z)
6030 !      include 'DIMENSIONS'
6031 !      include 'COMMON.LOCAL'
6032 !      include 'COMMON.IOUNITS'
6033 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6034 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6035 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6036       integer :: i,j,k
6037       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
6038 !el      integer :: it
6039 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6040 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6041 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6042 !el local variables
6043       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
6044        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6045
6046 ! Calculate the contributions to both Gaussian lobes.
6047 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6048 ! The "polynomial part" of the "standard deviation" of this part of
6049 ! the distribution.
6050         sig=polthet(3,it)
6051         do j=2,0,-1
6052           sig=sig*thet_pred_mean+polthet(j,it)
6053         enddo
6054 ! Derivative of the "interior part" of the "standard deviation of the"
6055 ! gamma-dependent Gaussian lobe in t_c.
6056         sigtc=3*polthet(3,it)
6057         do j=2,1,-1
6058           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6059         enddo
6060         sigtc=sig*sigtc
6061 ! Set the parameters of both Gaussian lobes of the distribution.
6062 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6063         fac=sig*sig+sigc0(it)
6064         sigcsq=fac+fac
6065         sigc=1.0D0/sigcsq
6066 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6067         sigsqtc=-4.0D0*sigcsq*sigtc
6068 !       print *,i,sig,sigtc,sigsqtc
6069 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
6070         sigtc=-sigtc/(fac*fac)
6071 ! Following variable is sigma(t_c)**(-2)
6072         sigcsq=sigcsq*sigcsq
6073         sig0i=sig0(it)
6074         sig0inv=1.0D0/sig0i**2
6075         delthec=thetai-thet_pred_mean
6076         delthe0=thetai-theta0i
6077         term1=-0.5D0*sigcsq*delthec*delthec
6078         term2=-0.5D0*sig0inv*delthe0*delthe0
6079 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6080 ! NaNs in taking the logarithm. We extract the largest exponent which is added
6081 ! to the energy (this being the log of the distribution) at the end of energy
6082 ! term evaluation for this virtual-bond angle.
6083         if (term1.gt.term2) then
6084           termm=term1
6085           term2=dexp(term2-termm)
6086           term1=1.0d0
6087         else
6088           termm=term2
6089           term1=dexp(term1-termm)
6090           term2=1.0d0
6091         endif
6092 ! The ratio between the gamma-independent and gamma-dependent lobes of
6093 ! the distribution is a Gaussian function of thet_pred_mean too.
6094         diffak=gthet(2,it)-thet_pred_mean
6095         ratak=diffak/gthet(3,it)**2
6096         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6097 ! Let's differentiate it in thet_pred_mean NOW.
6098         aktc=ak*ratak
6099 ! Now put together the distribution terms to make complete distribution.
6100         termexp=term1+ak*term2
6101         termpre=sigc+ak*sig0i
6102 ! Contribution of the bending energy from this theta is just the -log of
6103 ! the sum of the contributions from the two lobes and the pre-exponential
6104 ! factor. Simple enough, isn't it?
6105         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6106 ! NOW the derivatives!!!
6107 ! 6/6/97 Take into account the deformation.
6108         E_theta=(delthec*sigcsq*term1 &
6109              +ak*delthe0*sig0inv*term2)/termexp
6110         E_tc=((sigtc+aktc*sig0i)/termpre &
6111             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
6112              aktc*term2)/termexp)
6113       return
6114       end subroutine theteng
6115 #else
6116 !-----------------------------------------------------------------------------
6117       subroutine ebend(etheta)
6118 !
6119 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6120 ! angles gamma and its derivatives in consecutive thetas and gammas.
6121 ! ab initio-derived potentials from
6122 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6123 !
6124 !      implicit real*8 (a-h,o-z)
6125 !      include 'DIMENSIONS'
6126 !      include 'COMMON.LOCAL'
6127 !      include 'COMMON.GEO'
6128 !      include 'COMMON.INTERACT'
6129 !      include 'COMMON.DERIV'
6130 !      include 'COMMON.VAR'
6131 !      include 'COMMON.CHAIN'
6132 !      include 'COMMON.IOUNITS'
6133 !      include 'COMMON.NAMES'
6134 !      include 'COMMON.FFIELD'
6135 !      include 'COMMON.CONTROL'
6136       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
6137       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
6138       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
6139       logical :: lprn=.false., lprn1=.false.
6140 !el local variables
6141       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
6142       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
6143       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
6144 ! local variables for constrains
6145       real(kind=8) :: difi,thetiii
6146        integer itheta
6147 !      write(iout,*) "in ebend",ithet_start,ithet_end
6148       call flush(iout)
6149       etheta=0.0D0
6150       do i=ithet_start,ithet_end
6151         if (itype(i-1,1).eq.ntyp1) cycle
6152         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
6153         if (iabs(itype(i+1,1)).eq.20) iblock=2
6154         if (iabs(itype(i+1,1)).ne.20) iblock=1
6155         dethetai=0.0d0
6156         dephii=0.0d0
6157         dephii1=0.0d0
6158         theti2=0.5d0*theta(i)
6159         ityp2=ithetyp((itype(i-1,1)))
6160         do k=1,nntheterm
6161           coskt(k)=dcos(k*theti2)
6162           sinkt(k)=dsin(k*theti2)
6163         enddo
6164         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
6165 #ifdef OSF
6166           phii=phi(i)
6167           if (phii.ne.phii) phii=150.0
6168 #else
6169           phii=phi(i)
6170 #endif
6171           ityp1=ithetyp((itype(i-2,1)))
6172 ! propagation of chirality for glycine type
6173           do k=1,nsingle
6174             cosph1(k)=dcos(k*phii)
6175             sinph1(k)=dsin(k*phii)
6176           enddo
6177         else
6178           phii=0.0d0
6179           ityp1=ithetyp(itype(i-2,1))
6180           do k=1,nsingle
6181             cosph1(k)=0.0d0
6182             sinph1(k)=0.0d0
6183           enddo
6184         endif
6185         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
6186 #ifdef OSF
6187           phii1=phi(i+1)
6188           if (phii1.ne.phii1) phii1=150.0
6189           phii1=pinorm(phii1)
6190 #else
6191           phii1=phi(i+1)
6192 #endif
6193           ityp3=ithetyp((itype(i,1)))
6194           do k=1,nsingle
6195             cosph2(k)=dcos(k*phii1)
6196             sinph2(k)=dsin(k*phii1)
6197           enddo
6198         else
6199           phii1=0.0d0
6200           ityp3=ithetyp(itype(i,1))
6201           do k=1,nsingle
6202             cosph2(k)=0.0d0
6203             sinph2(k)=0.0d0
6204           enddo
6205         endif
6206         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6207         do k=1,ndouble
6208           do l=1,k-1
6209             ccl=cosph1(l)*cosph2(k-l)
6210             ssl=sinph1(l)*sinph2(k-l)
6211             scl=sinph1(l)*cosph2(k-l)
6212             csl=cosph1(l)*sinph2(k-l)
6213             cosph1ph2(l,k)=ccl-ssl
6214             cosph1ph2(k,l)=ccl+ssl
6215             sinph1ph2(l,k)=scl+csl
6216             sinph1ph2(k,l)=scl-csl
6217           enddo
6218         enddo
6219         if (lprn) then
6220         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
6221           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6222         write (iout,*) "coskt and sinkt"
6223         do k=1,nntheterm
6224           write (iout,*) k,coskt(k),sinkt(k)
6225         enddo
6226         endif
6227         do k=1,ntheterm
6228           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6229           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
6230             *coskt(k)
6231           if (lprn) &
6232           write (iout,*) "k",k,&
6233            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
6234            " ethetai",ethetai
6235         enddo
6236         if (lprn) then
6237         write (iout,*) "cosph and sinph"
6238         do k=1,nsingle
6239           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6240         enddo
6241         write (iout,*) "cosph1ph2 and sinph2ph2"
6242         do k=2,ndouble
6243           do l=1,k-1
6244             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
6245                sinph1ph2(l,k),sinph1ph2(k,l)
6246           enddo
6247         enddo
6248         write(iout,*) "ethetai",ethetai
6249         endif
6250         do m=1,ntheterm2
6251           do k=1,nsingle
6252             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
6253                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
6254                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
6255                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6256             ethetai=ethetai+sinkt(m)*aux
6257             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6258             dephii=dephii+k*sinkt(m)* &
6259                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
6260                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6261             dephii1=dephii1+k*sinkt(m)* &
6262                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
6263                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6264             if (lprn) &
6265             write (iout,*) "m",m," k",k," bbthet", &
6266                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
6267                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
6268                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
6269                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6270           enddo
6271         enddo
6272         if (lprn) &
6273         write(iout,*) "ethetai",ethetai
6274         do m=1,ntheterm3
6275           do k=2,ndouble
6276             do l=1,k-1
6277               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6278                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
6279                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6280                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6281               ethetai=ethetai+sinkt(m)*aux
6282               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6283               dephii=dephii+l*sinkt(m)* &
6284                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
6285                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6286                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6287                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6288               dephii1=dephii1+(k-l)*sinkt(m)* &
6289                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6290                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6291                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
6292                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6293               if (lprn) then
6294               write (iout,*) "m",m," k",k," l",l," ffthet",&
6295                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6296                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
6297                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6298                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
6299                   " ethetai",ethetai
6300               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
6301                   cosph1ph2(k,l)*sinkt(m),&
6302                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6303               endif
6304             enddo
6305           enddo
6306         enddo
6307 10      continue
6308 !        lprn1=.true.
6309         if (lprn1) &
6310           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
6311          i,theta(i)*rad2deg,phii*rad2deg,&
6312          phii1*rad2deg,ethetai
6313 !        lprn1=.false.
6314         etheta=etheta+ethetai
6315         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6316                                     'ebend',i,ethetai
6317         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6318         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6319         gloc(nphi+i-2,icg)=wang*dethetai
6320       enddo
6321 !-----------thete constrains
6322 !      if (tor_mode.ne.2) then
6323
6324       return
6325       end subroutine ebend
6326 #endif
6327 #ifdef CRYST_SC
6328 !-----------------------------------------------------------------------------
6329       subroutine esc(escloc)
6330 ! Calculate the local energy of a side chain and its derivatives in the
6331 ! corresponding virtual-bond valence angles THETA and the spherical angles
6332 ! ALPHA and OMEGA.
6333 !
6334       use comm_sccalc
6335 !      implicit real*8 (a-h,o-z)
6336 !      include 'DIMENSIONS'
6337 !      include 'COMMON.GEO'
6338 !      include 'COMMON.LOCAL'
6339 !      include 'COMMON.VAR'
6340 !      include 'COMMON.INTERACT'
6341 !      include 'COMMON.DERIV'
6342 !      include 'COMMON.CHAIN'
6343 !      include 'COMMON.IOUNITS'
6344 !      include 'COMMON.NAMES'
6345 !      include 'COMMON.FFIELD'
6346 !      include 'COMMON.CONTROL'
6347       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
6348          ddersc0,ddummy,xtemp,temp
6349 !el      real(kind=8) :: time11,time12,time112,theti
6350       real(kind=8) :: escloc,delta
6351 !el      integer :: it,nlobit
6352 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6353 !el local variables
6354       integer :: i,k
6355       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
6356        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6357       delta=0.02d0*pi
6358       escloc=0.0D0
6359 !     write (iout,'(a)') 'ESC'
6360       do i=loc_start,loc_end
6361         it=itype(i,1)
6362         if (it.eq.ntyp1) cycle
6363         if (it.eq.10) goto 1
6364         nlobit=nlob(iabs(it))
6365 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
6366 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6367         theti=theta(i+1)-pipol
6368         x(1)=dtan(theti)
6369         x(2)=alph(i)
6370         x(3)=omeg(i)
6371
6372         if (x(2).gt.pi-delta) then
6373           xtemp(1)=x(1)
6374           xtemp(2)=pi-delta
6375           xtemp(3)=x(3)
6376           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6377           xtemp(2)=pi
6378           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6379           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
6380               escloci,dersc(2))
6381           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6382               ddersc0(1),dersc(1))
6383           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
6384               ddersc0(3),dersc(3))
6385           xtemp(2)=pi-delta
6386           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6387           xtemp(2)=pi
6388           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6389           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
6390                   dersc0(2),esclocbi,dersc02)
6391           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6392                   dersc12,dersc01)
6393           call splinthet(x(2),0.5d0*delta,ss,ssd)
6394           dersc0(1)=dersc01
6395           dersc0(2)=dersc02
6396           dersc0(3)=0.0d0
6397           do k=1,3
6398             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6399           enddo
6400           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6401 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6402 !    &             esclocbi,ss,ssd
6403           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6404 !         escloci=esclocbi
6405 !         write (iout,*) escloci
6406         else if (x(2).lt.delta) then
6407           xtemp(1)=x(1)
6408           xtemp(2)=delta
6409           xtemp(3)=x(3)
6410           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6411           xtemp(2)=0.0d0
6412           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6413           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
6414               escloci,dersc(2))
6415           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6416               ddersc0(1),dersc(1))
6417           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6418               ddersc0(3),dersc(3))
6419           xtemp(2)=delta
6420           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6421           xtemp(2)=0.0d0
6422           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6423           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6424                   dersc0(2),esclocbi,dersc02)
6425           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6426                   dersc12,dersc01)
6427           dersc0(1)=dersc01
6428           dersc0(2)=dersc02
6429           dersc0(3)=0.0d0
6430           call splinthet(x(2),0.5d0*delta,ss,ssd)
6431           do k=1,3
6432             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6433           enddo
6434           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6435 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6436 !    &             esclocbi,ss,ssd
6437           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6438 !         write (iout,*) escloci
6439         else
6440           call enesc(x,escloci,dersc,ddummy,.false.)
6441         endif
6442
6443         escloc=escloc+escloci
6444         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6445            'escloc',i,escloci
6446 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6447
6448         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6449          wscloc*dersc(1)
6450         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6451         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6452     1   continue
6453       enddo
6454       return
6455       end subroutine esc
6456 !-----------------------------------------------------------------------------
6457       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6458
6459       use comm_sccalc
6460 !      implicit real*8 (a-h,o-z)
6461 !      include 'DIMENSIONS'
6462 !      include 'COMMON.GEO'
6463 !      include 'COMMON.LOCAL'
6464 !      include 'COMMON.IOUNITS'
6465 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6466       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6467       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6468       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6469       real(kind=8) :: escloci
6470       logical :: mixed
6471 !el local variables
6472       integer :: j,iii,l,k !el,it,nlobit
6473       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6474 !el       time11,time12,time112
6475 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6476         escloc_i=0.0D0
6477         do j=1,3
6478           dersc(j)=0.0D0
6479           if (mixed) ddersc(j)=0.0d0
6480         enddo
6481         x3=x(3)
6482
6483 ! Because of periodicity of the dependence of the SC energy in omega we have
6484 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6485 ! To avoid underflows, first compute & store the exponents.
6486
6487         do iii=-1,1
6488
6489           x(3)=x3+iii*dwapi
6490
6491           do j=1,nlobit
6492             do k=1,3
6493               z(k)=x(k)-censc(k,j,it)
6494             enddo
6495             do k=1,3
6496               Axk=0.0D0
6497               do l=1,3
6498                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6499               enddo
6500               Ax(k,j,iii)=Axk
6501             enddo
6502             expfac=0.0D0
6503             do k=1,3
6504               expfac=expfac+Ax(k,j,iii)*z(k)
6505             enddo
6506             contr(j,iii)=expfac
6507           enddo ! j
6508
6509         enddo ! iii
6510
6511         x(3)=x3
6512 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6513 ! subsequent NaNs and INFs in energy calculation.
6514 ! Find the largest exponent
6515         emin=contr(1,-1)
6516         do iii=-1,1
6517           do j=1,nlobit
6518             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6519           enddo
6520         enddo
6521         emin=0.5D0*emin
6522 !d      print *,'it=',it,' emin=',emin
6523
6524 ! Compute the contribution to SC energy and derivatives
6525         do iii=-1,1
6526
6527           do j=1,nlobit
6528 #ifdef OSF
6529             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6530             if(adexp.ne.adexp) adexp=1.0
6531             expfac=dexp(adexp)
6532 #else
6533             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6534 #endif
6535 !d          print *,'j=',j,' expfac=',expfac
6536             escloc_i=escloc_i+expfac
6537             do k=1,3
6538               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6539             enddo
6540             if (mixed) then
6541               do k=1,3,2
6542                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6543                   +gaussc(k,2,j,it))*expfac
6544               enddo
6545             endif
6546           enddo
6547
6548         enddo ! iii
6549
6550         dersc(1)=dersc(1)/cos(theti)**2
6551         ddersc(1)=ddersc(1)/cos(theti)**2
6552         ddersc(3)=ddersc(3)
6553
6554         escloci=-(dlog(escloc_i)-emin)
6555         do j=1,3
6556           dersc(j)=dersc(j)/escloc_i
6557         enddo
6558         if (mixed) then
6559           do j=1,3,2
6560             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6561           enddo
6562         endif
6563       return
6564       end subroutine enesc
6565 !-----------------------------------------------------------------------------
6566       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6567
6568       use comm_sccalc
6569 !      implicit real*8 (a-h,o-z)
6570 !      include 'DIMENSIONS'
6571 !      include 'COMMON.GEO'
6572 !      include 'COMMON.LOCAL'
6573 !      include 'COMMON.IOUNITS'
6574 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6575       real(kind=8),dimension(3) :: x,z,dersc
6576       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6577       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6578       real(kind=8) :: escloci,dersc12,emin
6579       logical :: mixed
6580 !el local varables
6581       integer :: j,k,l !el,it,nlobit
6582       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6583
6584       escloc_i=0.0D0
6585
6586       do j=1,3
6587         dersc(j)=0.0D0
6588       enddo
6589
6590       do j=1,nlobit
6591         do k=1,2
6592           z(k)=x(k)-censc(k,j,it)
6593         enddo
6594         z(3)=dwapi
6595         do k=1,3
6596           Axk=0.0D0
6597           do l=1,3
6598             Axk=Axk+gaussc(l,k,j,it)*z(l)
6599           enddo
6600           Ax(k,j)=Axk
6601         enddo
6602         expfac=0.0D0
6603         do k=1,3
6604           expfac=expfac+Ax(k,j)*z(k)
6605         enddo
6606         contr(j)=expfac
6607       enddo ! j
6608
6609 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6610 ! subsequent NaNs and INFs in energy calculation.
6611 ! Find the largest exponent
6612       emin=contr(1)
6613       do j=1,nlobit
6614         if (emin.gt.contr(j)) emin=contr(j)
6615       enddo
6616       emin=0.5D0*emin
6617
6618 ! Compute the contribution to SC energy and derivatives
6619
6620       dersc12=0.0d0
6621       do j=1,nlobit
6622         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6623         escloc_i=escloc_i+expfac
6624         do k=1,2
6625           dersc(k)=dersc(k)+Ax(k,j)*expfac
6626         enddo
6627         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6628                   +gaussc(1,2,j,it))*expfac
6629         dersc(3)=0.0d0
6630       enddo
6631
6632       dersc(1)=dersc(1)/cos(theti)**2
6633       dersc12=dersc12/cos(theti)**2
6634       escloci=-(dlog(escloc_i)-emin)
6635       do j=1,2
6636         dersc(j)=dersc(j)/escloc_i
6637       enddo
6638       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6639       return
6640       end subroutine enesc_bound
6641 #else
6642 !-----------------------------------------------------------------------------
6643       subroutine esc(escloc)
6644 ! Calculate the local energy of a side chain and its derivatives in the
6645 ! corresponding virtual-bond valence angles THETA and the spherical angles
6646 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6647 ! added by Urszula Kozlowska. 07/11/2007
6648 !
6649       use comm_sccalc
6650 !      implicit real*8 (a-h,o-z)
6651 !      include 'DIMENSIONS'
6652 !      include 'COMMON.GEO'
6653 !      include 'COMMON.LOCAL'
6654 !      include 'COMMON.VAR'
6655 !      include 'COMMON.SCROT'
6656 !      include 'COMMON.INTERACT'
6657 !      include 'COMMON.DERIV'
6658 !      include 'COMMON.CHAIN'
6659 !      include 'COMMON.IOUNITS'
6660 !      include 'COMMON.NAMES'
6661 !      include 'COMMON.FFIELD'
6662 !      include 'COMMON.CONTROL'
6663 !      include 'COMMON.VECTORS'
6664       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6665       real(kind=8),dimension(65) :: x
6666       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6667          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6668       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6669       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6670          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6671 !el local variables
6672       integer :: i,j,k !el,it,nlobit
6673       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6674 !el      real(kind=8) :: time11,time12,time112,theti
6675 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6676       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6677                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6678                    sumene1x,sumene2x,sumene3x,sumene4x,&
6679                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6680                    cosfac2xx,sinfac2yy
6681 #ifdef DEBUG
6682       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6683                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6684                    de_dt_num
6685 #endif
6686 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6687
6688       delta=0.02d0*pi
6689       escloc=0.0D0
6690       do i=loc_start,loc_end
6691         if (itype(i,1).eq.ntyp1) cycle
6692         costtab(i+1) =dcos(theta(i+1))
6693         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6694         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6695         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6696         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6697         cosfac=dsqrt(cosfac2)
6698         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6699         sinfac=dsqrt(sinfac2)
6700         it=iabs(itype(i,1))
6701         if (it.eq.10) goto 1
6702 !
6703 !  Compute the axes of tghe local cartesian coordinates system; store in
6704 !   x_prime, y_prime and z_prime
6705 !
6706         do j=1,3
6707           x_prime(j) = 0.00
6708           y_prime(j) = 0.00
6709           z_prime(j) = 0.00
6710         enddo
6711 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6712 !     &   dc_norm(3,i+nres)
6713         do j = 1,3
6714           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6715           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6716         enddo
6717         do j = 1,3
6718           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6719         enddo
6720 !       write (2,*) "i",i
6721 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6722 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6723 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6724 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6725 !      & " xy",scalar(x_prime(1),y_prime(1)),
6726 !      & " xz",scalar(x_prime(1),z_prime(1)),
6727 !      & " yy",scalar(y_prime(1),y_prime(1)),
6728 !      & " yz",scalar(y_prime(1),z_prime(1)),
6729 !      & " zz",scalar(z_prime(1),z_prime(1))
6730 !
6731 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6732 ! to local coordinate system. Store in xx, yy, zz.
6733 !
6734         xx=0.0d0
6735         yy=0.0d0
6736         zz=0.0d0
6737         do j = 1,3
6738           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6739           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6740           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6741         enddo
6742
6743         xxtab(i)=xx
6744         yytab(i)=yy
6745         zztab(i)=zz
6746 !
6747 ! Compute the energy of the ith side cbain
6748 !
6749 !        write (2,*) "xx",xx," yy",yy," zz",zz
6750         it=iabs(itype(i,1))
6751         do j = 1,65
6752           x(j) = sc_parmin(j,it)
6753         enddo
6754 #ifdef CHECK_COORD
6755 !c diagnostics - remove later
6756         xx1 = dcos(alph(2))
6757         yy1 = dsin(alph(2))*dcos(omeg(2))
6758         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6759         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6760           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6761           xx1,yy1,zz1
6762 !,"  --- ", xx_w,yy_w,zz_w
6763 ! end diagnostics
6764 #endif
6765         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6766          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6767          + x(10)*yy*zz
6768         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6769          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6770          + x(20)*yy*zz
6771         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6772          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6773          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6774          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6775          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6776          +x(40)*xx*yy*zz
6777         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6778          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6779          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6780          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6781          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6782          +x(60)*xx*yy*zz
6783         dsc_i   = 0.743d0+x(61)
6784         dp2_i   = 1.9d0+x(62)
6785         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6786                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6787         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6788                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6789         s1=(1+x(63))/(0.1d0 + dscp1)
6790         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6791         s2=(1+x(65))/(0.1d0 + dscp2)
6792         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6793         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6794       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6795 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6796 !     &   sumene4,
6797 !     &   dscp1,dscp2,sumene
6798 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6799         escloc = escloc + sumene
6800        if (energy_dec) write (2,*) "i",i," itype",itype(i,1)," it",it, &
6801         " escloc",sumene,escloc,it,itype(i,1)
6802 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6803 !     & ,zz,xx,yy
6804 !#define DEBUG
6805 #ifdef DEBUG
6806 !
6807 ! This section to check the numerical derivatives of the energy of ith side
6808 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6809 ! #define DEBUG in the code to turn it on.
6810 !
6811         write (2,*) "sumene               =",sumene
6812         aincr=1.0d-7
6813         xxsave=xx
6814         xx=xx+aincr
6815         write (2,*) xx,yy,zz
6816         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6817         de_dxx_num=(sumenep-sumene)/aincr
6818         xx=xxsave
6819         write (2,*) "xx+ sumene from enesc=",sumenep
6820         yysave=yy
6821         yy=yy+aincr
6822         write (2,*) xx,yy,zz
6823         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6824         de_dyy_num=(sumenep-sumene)/aincr
6825         yy=yysave
6826         write (2,*) "yy+ sumene from enesc=",sumenep
6827         zzsave=zz
6828         zz=zz+aincr
6829         write (2,*) xx,yy,zz
6830         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6831         de_dzz_num=(sumenep-sumene)/aincr
6832         zz=zzsave
6833         write (2,*) "zz+ sumene from enesc=",sumenep
6834         costsave=cost2tab(i+1)
6835         sintsave=sint2tab(i+1)
6836         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6837         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6838         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6839         de_dt_num=(sumenep-sumene)/aincr
6840         write (2,*) " t+ sumene from enesc=",sumenep
6841         cost2tab(i+1)=costsave
6842         sint2tab(i+1)=sintsave
6843 ! End of diagnostics section.
6844 #endif
6845 !
6846 ! Compute the gradient of esc
6847 !
6848 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6849         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6850         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6851         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6852         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6853         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6854         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6855         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6856         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6857         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6858            *(pom_s1/dscp1+pom_s16*dscp1**4)
6859         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6860            *(pom_s2/dscp2+pom_s26*dscp2**4)
6861         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6862         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6863         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6864         +x(40)*yy*zz
6865         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6866         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6867         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6868         +x(60)*yy*zz
6869         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6870               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6871               +(pom1+pom2)*pom_dx
6872 #ifdef DEBUG
6873         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6874 #endif
6875 !
6876         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6877         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6878         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6879         +x(40)*xx*zz
6880         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6881         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6882         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6883         +x(59)*zz**2 +x(60)*xx*zz
6884         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6885               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6886               +(pom1-pom2)*pom_dy
6887 #ifdef DEBUG
6888         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6889 #endif
6890 !
6891         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6892         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6893         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6894         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6895         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6896         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6897         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6898         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6899 #ifdef DEBUG
6900         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
6901 #endif
6902 !
6903         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6904         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6905         +pom1*pom_dt1+pom2*pom_dt2
6906 #ifdef DEBUG
6907         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
6908 #endif
6909 !
6910 !
6911        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6912        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6913        cosfac2xx=cosfac2*xx
6914        sinfac2yy=sinfac2*yy
6915        do k = 1,3
6916          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6917             vbld_inv(i+1)
6918          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6919             vbld_inv(i)
6920          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6921          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6922 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6923 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6924 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6925 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6926          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6927          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6928          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6929          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6930          dZZ_Ci1(k)=0.0d0
6931          dZZ_Ci(k)=0.0d0
6932          do j=1,3
6933            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6934            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6935            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6936            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6937          enddo
6938
6939          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6940          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6941          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6942          (z_prime(k)-zz*dC_norm(k,i+nres))
6943 !
6944          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6945          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6946        enddo
6947
6948        do k=1,3
6949          dXX_Ctab(k,i)=dXX_Ci(k)
6950          dXX_C1tab(k,i)=dXX_Ci1(k)
6951          dYY_Ctab(k,i)=dYY_Ci(k)
6952          dYY_C1tab(k,i)=dYY_Ci1(k)
6953          dZZ_Ctab(k,i)=dZZ_Ci(k)
6954          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6955          dXX_XYZtab(k,i)=dXX_XYZ(k)
6956          dYY_XYZtab(k,i)=dYY_XYZ(k)
6957          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6958        enddo
6959
6960        do k = 1,3
6961 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6962 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6963 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6964 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6965 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6966 !     &    dt_dci(k)
6967 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6968 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6969          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6970           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6971          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6972           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6973          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6974           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6975        enddo
6976 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6977 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6978
6979 ! to check gradient call subroutine check_grad
6980
6981     1 continue
6982       enddo
6983       return
6984       end subroutine esc
6985 !-----------------------------------------------------------------------------
6986       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6987 !      implicit none
6988       real(kind=8),dimension(65) :: x
6989       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6990         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6991
6992       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6993         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6994         + x(10)*yy*zz
6995       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6996         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6997         + x(20)*yy*zz
6998       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6999         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
7000         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
7001         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
7002         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
7003         +x(40)*xx*yy*zz
7004       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
7005         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
7006         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
7007         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
7008         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
7009         +x(60)*xx*yy*zz
7010       dsc_i   = 0.743d0+x(61)
7011       dp2_i   = 1.9d0+x(62)
7012       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7013                 *(xx*cost2+yy*sint2))
7014       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7015                 *(xx*cost2-yy*sint2))
7016       s1=(1+x(63))/(0.1d0 + dscp1)
7017       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7018       s2=(1+x(65))/(0.1d0 + dscp2)
7019       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7020       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
7021        + (sumene4*cost2 +sumene2)*(s2+s2_6)
7022       enesc=sumene
7023       return
7024       end function enesc
7025 #endif
7026 !-----------------------------------------------------------------------------
7027       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7028 !
7029 ! This procedure calculates two-body contact function g(rij) and its derivative:
7030 !
7031 !           eps0ij                                     !       x < -1
7032 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7033 !            0                                         !       x > 1
7034 !
7035 ! where x=(rij-r0ij)/delta
7036 !
7037 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7038 !
7039 !      implicit none
7040       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
7041       real(kind=8) :: x,x2,x4,delta
7042 !     delta=0.02D0*r0ij
7043 !      delta=0.2D0*r0ij
7044       x=(rij-r0ij)/delta
7045       if (x.lt.-1.0D0) then
7046         fcont=eps0ij
7047         fprimcont=0.0D0
7048       else if (x.le.1.0D0) then
7049         x2=x*x
7050         x4=x2*x2
7051         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7052         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7053       else
7054         fcont=0.0D0
7055         fprimcont=0.0D0
7056       endif
7057       return
7058       end subroutine gcont
7059 !-----------------------------------------------------------------------------
7060       subroutine splinthet(theti,delta,ss,ssder)
7061 !      implicit real*8 (a-h,o-z)
7062 !      include 'DIMENSIONS'
7063 !      include 'COMMON.VAR'
7064 !      include 'COMMON.GEO'
7065       real(kind=8) :: theti,delta,ss,ssder
7066       real(kind=8) :: thetup,thetlow
7067       thetup=pi-delta
7068       thetlow=delta
7069       if (theti.gt.pipol) then
7070         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7071       else
7072         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7073         ssder=-ssder
7074       endif
7075       return
7076       end subroutine splinthet
7077 !-----------------------------------------------------------------------------
7078       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7079 !      implicit none
7080       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
7081       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7082       a1=fprim0*delta/(f1-f0)
7083       a2=3.0d0-2.0d0*a1
7084       a3=a1-2.0d0
7085       ksi=(x-x0)/delta
7086       ksi2=ksi*ksi
7087       ksi3=ksi2*ksi
7088       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7089       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7090       return
7091       end subroutine spline1
7092 !-----------------------------------------------------------------------------
7093       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7094 !      implicit none
7095       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
7096       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7097       ksi=(x-x0)/delta
7098       ksi2=ksi*ksi
7099       ksi3=ksi2*ksi
7100       a1=fprim0x*delta
7101       a2=3*(f1x-f0x)-2*fprim0x*delta
7102       a3=fprim0x*delta-2*(f1x-f0x)
7103       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7104       return
7105       end subroutine spline2
7106 !-----------------------------------------------------------------------------
7107 #ifdef CRYST_TOR
7108 !-----------------------------------------------------------------------------
7109       subroutine etor(etors,edihcnstr)
7110 !      implicit real*8 (a-h,o-z)
7111 !      include 'DIMENSIONS'
7112 !      include 'COMMON.VAR'
7113 !      include 'COMMON.GEO'
7114 !      include 'COMMON.LOCAL'
7115 !      include 'COMMON.TORSION'
7116 !      include 'COMMON.INTERACT'
7117 !      include 'COMMON.DERIV'
7118 !      include 'COMMON.CHAIN'
7119 !      include 'COMMON.NAMES'
7120 !      include 'COMMON.IOUNITS'
7121 !      include 'COMMON.FFIELD'
7122 !      include 'COMMON.TORCNSTR'
7123 !      include 'COMMON.CONTROL'
7124       real(kind=8) :: etors,edihcnstr
7125       logical :: lprn
7126 !el local variables
7127       integer :: i,j,
7128       real(kind=8) :: phii,fac,etors_ii
7129
7130 ! Set lprn=.true. for debugging
7131       lprn=.false.
7132 !      lprn=.true.
7133       etors=0.0D0
7134       do i=iphi_start,iphi_end
7135       etors_ii=0.0D0
7136         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7137             .or. itype(i,1).eq.ntyp1) cycle
7138         itori=itortyp(itype(i-2,1))
7139         itori1=itortyp(itype(i-1,1))
7140         phii=phi(i)
7141         gloci=0.0D0
7142 ! Proline-Proline pair is a special case...
7143         if (itori.eq.3 .and. itori1.eq.3) then
7144           if (phii.gt.-dwapi3) then
7145             cosphi=dcos(3*phii)
7146             fac=1.0D0/(1.0D0-cosphi)
7147             etorsi=v1(1,3,3)*fac
7148             etorsi=etorsi+etorsi
7149             etors=etors+etorsi-v1(1,3,3)
7150             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7151             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7152           endif
7153           do j=1,3
7154             v1ij=v1(j+1,itori,itori1)
7155             v2ij=v2(j+1,itori,itori1)
7156             cosphi=dcos(j*phii)
7157             sinphi=dsin(j*phii)
7158             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7159             if (energy_dec) etors_ii=etors_ii+ &
7160                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7161             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7162           enddo
7163         else
7164           do j=1,nterm_old
7165             v1ij=v1(j,itori,itori1)
7166             v2ij=v2(j,itori,itori1)
7167             cosphi=dcos(j*phii)
7168             sinphi=dsin(j*phii)
7169             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7170             if (energy_dec) etors_ii=etors_ii+ &
7171                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7172             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7173           enddo
7174         endif
7175         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7176              'etor',i,etors_ii
7177         if (lprn) &
7178         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7179         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7180         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7181         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7182 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7183       enddo
7184 ! 6/20/98 - dihedral angle constraints
7185       edihcnstr=0.0d0
7186       do i=1,ndih_constr
7187         itori=idih_constr(i)
7188         phii=phi(itori)
7189         difi=phii-phi0(i)
7190         if (difi.gt.drange(i)) then
7191           difi=difi-drange(i)
7192           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7193           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7194         else if (difi.lt.-drange(i)) then
7195           difi=difi+drange(i)
7196           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7197           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7198         endif
7199 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7200 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7201       enddo
7202 !      write (iout,*) 'edihcnstr',edihcnstr
7203       return
7204       end subroutine etor
7205 !-----------------------------------------------------------------------------
7206       subroutine etor_d(etors_d)
7207       real(kind=8) :: etors_d
7208       etors_d=0.0d0
7209       return
7210       end subroutine etor_d
7211 !-----------------------------------------------------------------------------
7212 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7213       subroutine e_modeller(ehomology_constr)
7214       real(kind=8) :: ehomology_constr
7215       ehomology_constr=0.0d0
7216       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7217       return
7218       end subroutine e_modeller
7219 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7220 #else
7221 !-----------------------------------------------------------------------------
7222       subroutine etor(etors)
7223 !      implicit real*8 (a-h,o-z)
7224 !      include 'DIMENSIONS'
7225 !      include 'COMMON.VAR'
7226 !      include 'COMMON.GEO'
7227 !      include 'COMMON.LOCAL'
7228 !      include 'COMMON.TORSION'
7229 !      include 'COMMON.INTERACT'
7230 !      include 'COMMON.DERIV'
7231 !      include 'COMMON.CHAIN'
7232 !      include 'COMMON.NAMES'
7233 !      include 'COMMON.IOUNITS'
7234 !      include 'COMMON.FFIELD'
7235 !      include 'COMMON.TORCNSTR'
7236 !      include 'COMMON.CONTROL'
7237       real(kind=8) :: etors,edihcnstr
7238       logical :: lprn
7239 !el local variables
7240       integer :: i,j,iblock,itori,itori1
7241       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7242                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
7243 ! Set lprn=.true. for debugging
7244       lprn=.false.
7245 !     lprn=.true.
7246       etors=0.0D0
7247       do i=iphi_start,iphi_end
7248         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7249              .or. itype(i-3,1).eq.ntyp1 &
7250              .or. itype(i,1).eq.ntyp1) cycle
7251         etors_ii=0.0D0
7252          if (iabs(itype(i,1)).eq.20) then
7253          iblock=2
7254          else
7255          iblock=1
7256          endif
7257         itori=itortyp(itype(i-2,1))
7258         itori1=itortyp(itype(i-1,1))
7259         phii=phi(i)
7260         gloci=0.0D0
7261 ! Regular cosine and sine terms
7262         do j=1,nterm(itori,itori1,iblock)
7263           v1ij=v1(j,itori,itori1,iblock)
7264           v2ij=v2(j,itori,itori1,iblock)
7265           cosphi=dcos(j*phii)
7266           sinphi=dsin(j*phii)
7267           etors=etors+v1ij*cosphi+v2ij*sinphi
7268           if (energy_dec) etors_ii=etors_ii+ &
7269                      v1ij*cosphi+v2ij*sinphi
7270           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7271         enddo
7272 ! Lorentz terms
7273 !                         v1
7274 !  E = SUM ----------------------------------- - v1
7275 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7276 !
7277         cosphi=dcos(0.5d0*phii)
7278         sinphi=dsin(0.5d0*phii)
7279         do j=1,nlor(itori,itori1,iblock)
7280           vl1ij=vlor1(j,itori,itori1)
7281           vl2ij=vlor2(j,itori,itori1)
7282           vl3ij=vlor3(j,itori,itori1)
7283           pom=vl2ij*cosphi+vl3ij*sinphi
7284           pom1=1.0d0/(pom*pom+1.0d0)
7285           etors=etors+vl1ij*pom1
7286           if (energy_dec) etors_ii=etors_ii+ &
7287                      vl1ij*pom1
7288           pom=-pom*pom1*pom1
7289           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7290         enddo
7291 ! Subtract the constant term
7292         etors=etors-v0(itori,itori1,iblock)
7293           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7294                'etor',i,etors_ii-v0(itori,itori1,iblock)
7295         if (lprn) &
7296         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7297         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7298         (v1(j,itori,itori1,iblock),j=1,6),&
7299         (v2(j,itori,itori1,iblock),j=1,6)
7300         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7301 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7302       enddo
7303 ! 6/20/98 - dihedral angle constraints
7304       return
7305       end subroutine etor
7306 !C The rigorous attempt to derive energy function
7307 !-------------------------------------------------------------------------------------------
7308       subroutine etor_kcc(etors)
7309       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7310       real(kind=8) :: etors,glocig,glocit1,glocit2,sinthet1,&
7311        sinthet2,costhet1,costhet2,sint1t2,sint1t2n,phii,sinphi,cosphi,&
7312        sint1t2n1,sumvalc,gradvalct1,gradvalct2,sumvals,gradvalst1,&
7313        gradvalst2,etori
7314       logical lprn
7315       integer :: i,j,itori,itori1,nval,k,l
7316
7317       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7318       etors=0.0D0
7319       do i=iphi_start,iphi_end
7320 !C ANY TWO ARE DUMMY ATOMS in row CYCLE
7321 !c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7322 !c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7323 !c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7324         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7325            .or. itype(i,1).eq.ntyp1 .or. itype(i-3,1).eq.ntyp1) cycle
7326         itori=itortyp(itype(i-2,1))
7327         itori1=itortyp(itype(i-1,1))
7328         phii=phi(i)
7329         glocig=0.0D0
7330         glocit1=0.0d0
7331         glocit2=0.0d0
7332 !C to avoid multiple devision by 2
7333 !c        theti22=0.5d0*theta(i)
7334 !C theta 12 is the theta_1 /2
7335 !C theta 22 is theta_2 /2
7336 !c        theti12=0.5d0*theta(i-1)
7337 !C and appropriate sinus function
7338         sinthet1=dsin(theta(i-1))
7339         sinthet2=dsin(theta(i))
7340         costhet1=dcos(theta(i-1))
7341         costhet2=dcos(theta(i))
7342 !C to speed up lets store its mutliplication
7343         sint1t2=sinthet2*sinthet1
7344         sint1t2n=1.0d0
7345 !C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7346 !C +d_n*sin(n*gamma)) *
7347 !C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7348 !C we have two sum 1) Non-Chebyshev which is with n and gamma
7349         nval=nterm_kcc_Tb(itori,itori1)
7350         c1(0)=0.0d0
7351         c2(0)=0.0d0
7352         c1(1)=1.0d0
7353         c2(1)=1.0d0
7354         do j=2,nval
7355           c1(j)=c1(j-1)*costhet1
7356           c2(j)=c2(j-1)*costhet2
7357         enddo
7358         etori=0.0d0
7359
7360        do j=1,nterm_kcc(itori,itori1)
7361           cosphi=dcos(j*phii)
7362           sinphi=dsin(j*phii)
7363           sint1t2n1=sint1t2n
7364           sint1t2n=sint1t2n*sint1t2
7365           sumvalc=0.0d0
7366           gradvalct1=0.0d0
7367           gradvalct2=0.0d0
7368           do k=1,nval
7369             do l=1,nval
7370               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7371               gradvalct1=gradvalct1+ &
7372                 (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7373               gradvalct2=gradvalct2+ &
7374                 (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7375             enddo
7376           enddo
7377           gradvalct1=-gradvalct1*sinthet1
7378           gradvalct2=-gradvalct2*sinthet2
7379           sumvals=0.0d0
7380           gradvalst1=0.0d0
7381           gradvalst2=0.0d0
7382           do k=1,nval
7383             do l=1,nval
7384               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7385               gradvalst1=gradvalst1+ &
7386                 (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7387               gradvalst2=gradvalst2+ &
7388                 (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7389             enddo
7390           enddo
7391           gradvalst1=-gradvalst1*sinthet1
7392           gradvalst2=-gradvalst2*sinthet2
7393           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7394           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7395 !C glocig is the gradient local i site in gamma
7396           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7397 !C now gradient over theta_1
7398          glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)&
7399         +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7400          glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)&
7401         +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7402         enddo ! j
7403         etors=etors+etori
7404         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7405 !C derivative over theta1
7406         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7407 !C now derivative over theta2
7408         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7409         if (lprn) then
7410          write (iout,*) i-2,i-1,itype(i-2,1),itype(i-1,1),itori,itori1,&
7411             theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7412           write (iout,*) "c1",(c1(k),k=0,nval), &
7413          " c2",(c2(k),k=0,nval)
7414         endif
7415       enddo
7416       return
7417        end  subroutine etor_kcc
7418 !------------------------------------------------------------------------------
7419
7420         subroutine etor_constr(edihcnstr)
7421       real(kind=8) :: etors,edihcnstr
7422       logical :: lprn
7423 !el local variables
7424       integer :: i,j,iblock,itori,itori1
7425       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7426                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom,&
7427                    gaudih_i,gauder_i,s,cos_i,dexpcos_i
7428
7429       if (raw_psipred) then
7430         do i=idihconstr_start,idihconstr_end
7431           itori=idih_constr(i)
7432           phii=phi(itori)
7433           gaudih_i=vpsipred(1,i)
7434           gauder_i=0.0d0
7435           do j=1,2
7436             s = sdihed(j,i)
7437             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7438             dexpcos_i=dexp(-cos_i*cos_i)
7439             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7440           gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i)) &
7441                  *cos_i*dexpcos_i/s**2
7442           enddo
7443           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7444           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7445           if (energy_dec) &
7446           write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)') &
7447           i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),&
7448           phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),&
7449           phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,&
7450           -wdihc*dlog(gaudih_i)
7451         enddo
7452       else
7453
7454       do i=idihconstr_start,idihconstr_end
7455         itori=idih_constr(i)
7456         phii=phi(itori)
7457         difi=pinorm(phii-phi0(i))
7458         if (difi.gt.drange(i)) then
7459           difi=difi-drange(i)
7460           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7461           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7462         else if (difi.lt.-drange(i)) then
7463           difi=difi+drange(i)
7464           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7465           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7466         else
7467           difi=0.0
7468         endif
7469       enddo
7470
7471       endif
7472
7473       return
7474
7475       end subroutine etor_constr
7476 !-----------------------------------------------------------------------------
7477       subroutine etor_d(etors_d)
7478 ! 6/23/01 Compute double torsional energy
7479 !      implicit real*8 (a-h,o-z)
7480 !      include 'DIMENSIONS'
7481 !      include 'COMMON.VAR'
7482 !      include 'COMMON.GEO'
7483 !      include 'COMMON.LOCAL'
7484 !      include 'COMMON.TORSION'
7485 !      include 'COMMON.INTERACT'
7486 !      include 'COMMON.DERIV'
7487 !      include 'COMMON.CHAIN'
7488 !      include 'COMMON.NAMES'
7489 !      include 'COMMON.IOUNITS'
7490 !      include 'COMMON.FFIELD'
7491 !      include 'COMMON.TORCNSTR'
7492       real(kind=8) :: etors_d,etors_d_ii
7493       logical :: lprn
7494 !el local variables
7495       integer :: i,j,k,l,itori,itori1,itori2,iblock
7496       real(kind=8) :: phii,phii1,gloci1,gloci2,&
7497                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
7498                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
7499                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
7500 ! Set lprn=.true. for debugging
7501       lprn=.false.
7502 !     lprn=.true.
7503       etors_d=0.0D0
7504 !      write(iout,*) "a tu??"
7505       do i=iphid_start,iphid_end
7506         etors_d_ii=0.0D0
7507         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7508             .or. itype(i-3,1).eq.ntyp1 &
7509             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
7510         itori=itortyp(itype(i-2,1))
7511         itori1=itortyp(itype(i-1,1))
7512         itori2=itortyp(itype(i,1))
7513         phii=phi(i)
7514         phii1=phi(i+1)
7515         gloci1=0.0D0
7516         gloci2=0.0D0
7517         iblock=1
7518         if (iabs(itype(i+1,1)).eq.20) iblock=2
7519
7520 ! Regular cosine and sine terms
7521         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7522           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7523           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7524           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7525           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7526           cosphi1=dcos(j*phii)
7527           sinphi1=dsin(j*phii)
7528           cosphi2=dcos(j*phii1)
7529           sinphi2=dsin(j*phii1)
7530           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
7531            v2cij*cosphi2+v2sij*sinphi2
7532           if (energy_dec) etors_d_ii=etors_d_ii+ &
7533            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7534           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7535           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7536         enddo
7537         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7538           do l=1,k-1
7539             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7540             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7541             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7542             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7543             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7544             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7545             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7546             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7547             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7548               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7549             if (energy_dec) etors_d_ii=etors_d_ii+ &
7550               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7551               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7552             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
7553               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7554             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
7555               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7556           enddo
7557         enddo
7558         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7559                             'etor_d',i,etors_d_ii
7560         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7561         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7562       enddo
7563       return
7564       end subroutine etor_d
7565 #endif
7566 !----------------------------------------------------------------------------
7567 !----------------------------------------------------------------------------
7568       subroutine e_modeller(ehomology_constr)
7569 !      implicit none
7570 !      include 'DIMENSIONS'
7571       use MD_data, only: iset
7572       real(kind=8) :: ehomology_constr
7573       integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
7574       integer katy, odleglosci, test7
7575       real(kind=8) :: odleg, odleg2, odleg3, kat, kat2, kat3
7576       real(kind=8) :: Eval,Erot,min_odl
7577       real(kind=8),dimension(constr_homology) :: distance,distancek,godl,dih_diff,gdih, &
7578       gtheta,dscdiff, &
7579                 uscdiffk,guscdiff2,guscdiff3,&
7580                 theta_diff
7581
7582
7583 !
7584 !     FP - 30/10/2014 Temporary specifications for homology restraints
7585 !
7586       real(kind=8) :: utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,&
7587                       sgtheta
7588       real(kind=8), dimension (nres) :: guscdiff,usc_diff
7589       real(kind=8) :: sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,&
7590       sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,&
7591       betai,sum_sgodl,dij,max_template
7592 !      real(kind=8) :: dist,pinorm
7593 !
7594 !     include 'COMMON.SBRIDGE'
7595 !     include 'COMMON.CHAIN'
7596 !     include 'COMMON.GEO'
7597 !     include 'COMMON.DERIV'
7598 !     include 'COMMON.LOCAL'
7599 !     include 'COMMON.INTERACT'
7600 !     include 'COMMON.VAR'
7601 !     include 'COMMON.IOUNITS'
7602 !      include 'COMMON.MD'
7603 !     include 'COMMON.CONTROL'
7604 !     include 'COMMON.HOMOLOGY'
7605 !     include 'COMMON.QRESTR'
7606 !
7607 !     From subroutine Econstr_back
7608 !
7609 !     include 'COMMON.NAMES'
7610 !     include 'COMMON.TIME1'
7611 !
7612
7613
7614       do i=1,max_template
7615         distancek(i)=9999999.9
7616       enddo
7617
7618
7619       odleg=0.0d0
7620
7621 ! Pseudo-energy and gradient from homology restraints (MODELLER-like
7622 ! function)
7623 ! AL 5/2/14 - Introduce list of restraints
7624 !     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7625 #ifdef DEBUG
7626       write(iout,*) "------- dist restrs start -------"
7627 #endif
7628       do ii = link_start_homo,link_end_homo
7629          i = ires_homo(ii)
7630          j = jres_homo(ii)
7631          dij=dist(i,j)
7632 !        write (iout,*) "dij(",i,j,") =",dij
7633          nexl=0
7634          do k=1,constr_homology
7635 !           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7636            if(.not.l_homo(k,ii)) then
7637              nexl=nexl+1
7638              cycle
7639            endif
7640            distance(k)=odl(k,ii)-dij
7641 !          write (iout,*) "distance(",k,") =",distance(k)
7642 !
7643 !          For Gaussian-type Urestr
7644 !
7645            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7646 !          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7647 !          write (iout,*) "distancek(",k,") =",distancek(k)
7648 !          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
7649 !
7650 !          For Lorentzian-type Urestr
7651 !
7652            if (waga_dist.lt.0.0d0) then
7653               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
7654               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)* &
7655                           (distance(k)**2+sigma_odlir(k,ii)**2))
7656            endif
7657          enddo
7658
7659 !         min_odl=minval(distancek)
7660          if (nexl.gt.0) then
7661            min_odl=0.0d0
7662          else
7663            do kk=1,constr_homology
7664             if(l_homo(kk,ii)) then
7665               min_odl=distancek(kk)
7666               exit
7667             endif
7668            enddo
7669            do kk=1,constr_homology
7670             if (l_homo(kk,ii) .and. distancek(kk).lt.min_odl) &
7671                    min_odl=distancek(kk)
7672            enddo
7673          endif
7674
7675 !        write (iout,* )"min_odl",min_odl
7676 #ifdef DEBUG
7677          write (iout,*) "ij dij",i,j,dij
7678          write (iout,*) "distance",(distance(k),k=1,constr_homology)
7679          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
7680          write (iout,* )"min_odl",min_odl
7681 #endif
7682 #ifdef OLDRESTR
7683          odleg2=0.0d0
7684 #else
7685          if (waga_dist.ge.0.0d0) then
7686            odleg2=nexl
7687          else
7688            odleg2=0.0d0
7689          endif
7690 #endif
7691          do k=1,constr_homology
7692 ! Nie wiem po co to liczycie jeszcze raz!
7693 !            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
7694 !     &              (2*(sigma_odl(i,j,k))**2))
7695            if(.not.l_homo(k,ii)) cycle
7696            if (waga_dist.ge.0.0d0) then
7697 !
7698 !          For Gaussian-type Urestr
7699 !
7700             godl(k)=dexp(-distancek(k)+min_odl)
7701             odleg2=odleg2+godl(k)
7702 !
7703 !          For Lorentzian-type Urestr
7704 !
7705            else
7706             odleg2=odleg2+distancek(k)
7707            endif
7708
7709 !cc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
7710 !cc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
7711 !cc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
7712 !cc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
7713
7714          enddo
7715 !        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7716 !        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7717 #ifdef DEBUG
7718          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7719          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7720 #endif
7721            if (waga_dist.ge.0.0d0) then
7722 !
7723 !          For Gaussian-type Urestr
7724 !
7725               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
7726 !
7727 !          For Lorentzian-type Urestr
7728 !
7729            else
7730               odleg=odleg+odleg2/constr_homology
7731            endif
7732 !
7733 !        write (iout,*) "odleg",odleg ! sum of -ln-s
7734 ! Gradient
7735 !
7736 !          For Gaussian-type Urestr
7737 !
7738          if (waga_dist.ge.0.0d0) sum_godl=odleg2
7739          sum_sgodl=0.0d0
7740          do k=1,constr_homology
7741 !            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7742 !     &           *waga_dist)+min_odl
7743 !          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
7744 !
7745          if(.not.l_homo(k,ii)) cycle
7746          if (waga_dist.ge.0.0d0) then
7747 !          For Gaussian-type Urestr
7748 !
7749            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
7750 !
7751 !          For Lorentzian-type Urestr
7752 !
7753          else
7754            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+ &
7755                 sigma_odlir(k,ii)**2)**2)
7756          endif
7757            sum_sgodl=sum_sgodl+sgodl
7758
7759 !            sgodl2=sgodl2+sgodl
7760 !      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
7761 !      write(iout,*) "constr_homology=",constr_homology
7762 !      write(iout,*) i, j, k, "TEST K"
7763          enddo
7764 !         print *, "ok",iset
7765          if (waga_dist.ge.0.0d0) then
7766 !
7767 !          For Gaussian-type Urestr
7768 !
7769             grad_odl3=waga_homology(iset)*waga_dist &
7770                      *sum_sgodl/(sum_godl*dij)
7771 !         print *, "ok"
7772 !
7773 !          For Lorentzian-type Urestr
7774 !
7775          else
7776 ! Original grad expr modified by analogy w Gaussian-type Urestr grad
7777 !           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
7778             grad_odl3=-waga_homology(iset)*waga_dist* &
7779                      sum_sgodl/(constr_homology*dij)
7780 !         print *, "ok2"
7781          endif
7782 !
7783 !        grad_odl3=sum_sgodl/(sum_godl*dij)
7784
7785
7786 !      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
7787 !      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
7788 !     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7789
7790 !cc      write(iout,*) godl, sgodl, grad_odl3
7791
7792 !          grad_odl=grad_odl+grad_odl3
7793
7794          do jik=1,3
7795             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
7796 !cc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
7797 !cc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
7798 !cc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7799             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
7800             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
7801 !cc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
7802 !cc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7803 !         if (i.eq.25.and.j.eq.27) then
7804 !         write(iout,*) "jik",jik,"i",i,"j",j
7805 !         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
7806 !         write(iout,*) "grad_odl3",grad_odl3
7807 !         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
7808 !         write(iout,*) "ggodl",ggodl
7809 !         write(iout,*) "ghpbc(",jik,i,")",
7810 !     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
7811 !     &                 ghpbc(jik,j)
7812 !         endif
7813          enddo
7814 !cc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
7815 !cc     & dLOG(odleg2),"-odleg=", -odleg
7816
7817       enddo ! ii-loop for dist
7818 #ifdef DEBUG
7819       write(iout,*) "------- dist restrs end -------"
7820 !     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
7821 !    &     waga_d.eq.1.0d0) call sum_gradient
7822 #endif
7823 ! Pseudo-energy and gradient from dihedral-angle restraints from
7824 ! homology templates
7825 !      write (iout,*) "End of distance loop"
7826 !      call flush(iout)
7827       kat=0.0d0
7828 !      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
7829 #ifdef DEBUG
7830       write(iout,*) "------- dih restrs start -------"
7831       do i=idihconstr_start_homo,idihconstr_end_homo
7832         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
7833       enddo
7834 #endif
7835       do i=idihconstr_start_homo,idihconstr_end_homo
7836         kat2=0.0d0
7837 !        betai=beta(i,i+1,i+2,i+3)
7838         betai = phi(i)
7839 !       write (iout,*) "betai =",betai
7840         do k=1,constr_homology
7841           dih_diff(k)=pinorm(dih(k,i)-betai)
7842 !d          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
7843 !d     &                  ,sigma_dih(k,i)
7844 !          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
7845 !     &                                   -(6.28318-dih_diff(i,k))
7846 !          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
7847 !     &                                   6.28318+dih_diff(i,k)
7848 #ifdef OLD_DIHED
7849           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7850 #else
7851           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7852 #endif
7853 !         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
7854           gdih(k)=dexp(kat3)
7855           kat2=kat2+gdih(k)
7856 !          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
7857 !          write(*,*)""
7858         enddo
7859 !       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
7860 !       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
7861 #ifdef DEBUG
7862         write (iout,*) "i",i," betai",betai," kat2",kat2
7863         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
7864 #endif
7865         if (kat2.le.1.0d-14) cycle
7866         kat=kat-dLOG(kat2/constr_homology)
7867 !       write (iout,*) "kat",kat ! sum of -ln-s
7868
7869 !cc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
7870 !cc     & dLOG(kat2), "-kat=", -kat
7871
7872 ! ----------------------------------------------------------------------
7873 ! Gradient
7874 ! ----------------------------------------------------------------------
7875
7876         sum_gdih=kat2
7877         sum_sgdih=0.0d0
7878         do k=1,constr_homology
7879 #ifdef OLD_DIHED
7880           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
7881 #else
7882           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
7883 #endif
7884 !         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
7885           sum_sgdih=sum_sgdih+sgdih
7886         enddo
7887 !       grad_dih3=sum_sgdih/sum_gdih
7888         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
7889 !         print *, "ok3"
7890
7891 !      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
7892 !cc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
7893 !cc     & gloc(nphi+i-3,icg)
7894         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
7895 !        if (i.eq.25) then
7896 !        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
7897 !        endif
7898 !cc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
7899 !cc     & gloc(nphi+i-3,icg)
7900
7901       enddo ! i-loop for dih
7902 #ifdef DEBUG
7903       write(iout,*) "------- dih restrs end -------"
7904 #endif
7905
7906 ! Pseudo-energy and gradient for theta angle restraints from
7907 ! homology templates
7908 ! FP 01/15 - inserted from econstr_local_test.F, loop structure
7909 ! adapted
7910
7911 !
7912 !     For constr_homology reference structures (FP)
7913 !
7914 !     Uconst_back_tot=0.0d0
7915       Eval=0.0d0
7916       Erot=0.0d0
7917 !     Econstr_back legacy
7918       do i=1,nres
7919 !     do i=ithet_start,ithet_end
7920        dutheta(i)=0.0d0
7921       enddo
7922 !     do i=loc_start,loc_end
7923       do i=-1,nres
7924         do j=1,3
7925           duscdiff(j,i)=0.0d0
7926           duscdiffx(j,i)=0.0d0
7927         enddo
7928       enddo
7929 !
7930 !     do iref=1,nref
7931 !     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
7932 !     write (iout,*) "waga_theta",waga_theta
7933       if (waga_theta.gt.0.0d0) then
7934 #ifdef DEBUG
7935       write (iout,*) "usampl",usampl
7936       write(iout,*) "------- theta restrs start -------"
7937 !     do i=ithet_start,ithet_end
7938 !       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
7939 !     enddo
7940 #endif
7941 !     write (iout,*) "maxres",maxres,"nres",nres
7942
7943       do i=ithet_start,ithet_end
7944 !
7945 !     do i=1,nfrag_back
7946 !       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
7947 !
7948 ! Deviation of theta angles wrt constr_homology ref structures
7949 !
7950         utheta_i=0.0d0 ! argument of Gaussian for single k
7951         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
7952 !       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
7953 !       over residues in a fragment
7954 !       write (iout,*) "theta(",i,")=",theta(i)
7955         do k=1,constr_homology
7956 !
7957 !         dtheta_i=theta(j)-thetaref(j,iref)
7958 !         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
7959           theta_diff(k)=thetatpl(k,i)-theta(i)
7960 !d          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
7961 !d     &                  ,sigma_theta(k,i)
7962
7963 !
7964           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
7965 !         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
7966           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
7967           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
7968 !         Gradient for single Gaussian restraint in subr Econstr_back
7969 !         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
7970 !
7971         enddo
7972 !       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
7973 !       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
7974
7975 !
7976 !         Gradient for multiple Gaussian restraint
7977         sum_gtheta=gutheta_i
7978         sum_sgtheta=0.0d0
7979         do k=1,constr_homology
7980 !        New generalized expr for multiple Gaussian from Econstr_back
7981          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
7982 !
7983 !        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
7984           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
7985         enddo
7986 !       Final value of gradient using same var as in Econstr_back
7987         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg) &
7988            +sum_sgtheta/sum_gtheta*waga_theta &
7989                     *waga_homology(iset)
7990 !         print *, "ok4"
7991
7992 !        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
7993 !     &               *waga_homology(iset)
7994 !       dutheta(i)=sum_sgtheta/sum_gtheta
7995 !
7996 !       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
7997         Eval=Eval-dLOG(gutheta_i/constr_homology)
7998 !       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
7999 !       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8000 !       Uconst_back=Uconst_back+utheta(i)
8001       enddo ! (i-loop for theta)
8002 #ifdef DEBUG
8003       write(iout,*) "------- theta restrs end -------"
8004 #endif
8005       endif
8006 !
8007 ! Deviation of local SC geometry
8008 !
8009 ! Separation of two i-loops (instructed by AL - 11/3/2014)
8010 !
8011 !     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8012 !     write (iout,*) "waga_d",waga_d
8013
8014 #ifdef DEBUG
8015       write(iout,*) "------- SC restrs start -------"
8016       write (iout,*) "Initial duscdiff,duscdiffx"
8017       do i=loc_start,loc_end
8018         write (iout,*) i,(duscdiff(jik,i),jik=1,3), &
8019                       (duscdiffx(jik,i),jik=1,3)
8020       enddo
8021 #endif
8022       do i=loc_start,loc_end
8023         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8024         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8025 !       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8026 !       write(iout,*) "xxtab, yytab, zztab"
8027 !       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8028         do k=1,constr_homology
8029 !
8030           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8031 !                                    Original sign inverted for calc of gradients (s. Econstr_back)
8032           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8033           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8034 !         write(iout,*) "dxx, dyy, dzz"
8035 !d          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8036 !
8037           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8038 !         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8039 !         uscdiffk(k)=usc_diff(i)
8040           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8041 !          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8042 !     &       " guscdiff2",guscdiff2(k)
8043           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8044 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8045 !     &      xxref(j),yyref(j),zzref(j)
8046         enddo
8047 !
8048 !       Gradient
8049 !
8050 !       Generalized expression for multiple Gaussian acc to that for a single
8051 !       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8052 !
8053 !       Original implementation
8054 !       sum_guscdiff=guscdiff(i)
8055 !
8056 !       sum_sguscdiff=0.0d0
8057 !       do k=1,constr_homology
8058 !          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8059 !          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8060 !          sum_sguscdiff=sum_sguscdiff+sguscdiff
8061 !       enddo
8062 !
8063 !       Implementation of new expressions for gradient (Jan. 2015)
8064 !
8065 !       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8066         do k=1,constr_homology
8067 !
8068 !       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8069 !       before. Now the drivatives should be correct
8070 !
8071           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8072 !                                  Original sign inverted for calc of gradients (s. Econstr_back)
8073           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8074           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8075           sum_guscdiff=guscdiff2(k)* &!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8076                       sigma_d(k,i) ! for the grad wrt r'
8077 !         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8078
8079 !
8080 !         New implementation
8081          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8082          do jik=1,3
8083             duscdiff(jik,i-1)=duscdiff(jik,i-1)+ &
8084             sum_guscdiff*(dXX_C1tab(jik,i)*dxx+ &
8085             dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8086             duscdiff(jik,i)=duscdiff(jik,i)+ &
8087             sum_guscdiff*(dXX_Ctab(jik,i)*dxx+ &
8088             dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8089             duscdiffx(jik,i)=duscdiffx(jik,i)+ &
8090             sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+ &
8091             dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8092 !         print *, "ok5"
8093 !
8094 #ifdef DEBUG
8095 !             write(iout,*) "jik",jik,"i",i
8096              write(iout,*) "dxx, dyy, dzz"
8097              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8098              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8099             write(iout,*) "sum_sguscdiff",sum_guscdiff,waga_homology(iset),waga_d
8100             write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8101             write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8102              write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8103              write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8104              write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8105              write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8106              write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8107              write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8108              write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8109              write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8110             write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8111             write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8112 !            endif
8113 #endif
8114          enddo
8115         enddo
8116 !         print *, "ok6"
8117 !
8118 !       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8119 !        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8120 !
8121 !        write (iout,*) i," uscdiff",uscdiff(i)
8122 !
8123 ! Put together deviations from local geometry
8124
8125 !       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8126 !      &            wfrag_back(3,i,iset)*uscdiff(i)
8127         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8128 !       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8129 !       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8130 !       Uconst_back=Uconst_back+usc_diff(i)
8131 !
8132 !     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8133 !
8134 !     New implment: multiplied by sum_sguscdiff
8135 !
8136
8137       enddo ! (i-loop for dscdiff)
8138
8139 !      endif
8140
8141 #ifdef DEBUG
8142       write(iout,*) "------- SC restrs end -------"
8143         write (iout,*) "------ After SC loop in e_modeller ------"
8144         do i=loc_start,loc_end
8145          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8146          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8147         enddo
8148       if (waga_theta.eq.1.0d0) then
8149       write (iout,*) "in e_modeller after SC restr end: dutheta"
8150       do i=ithet_start,ithet_end
8151         write (iout,*) i,dutheta(i)
8152       enddo
8153       endif
8154       if (waga_d.eq.1.0d0) then
8155       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8156       do i=1,nres
8157         write (iout,*) i,(duscdiff(j,i),j=1,3)
8158         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8159       enddo
8160       endif
8161 #endif
8162
8163 ! Total energy from homology restraints
8164 #ifdef DEBUG
8165       write (iout,*) "odleg",odleg," kat",kat
8166 #endif
8167 !
8168 ! Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8169 !
8170 !     ehomology_constr=odleg+kat
8171 !
8172 !     For Lorentzian-type Urestr
8173 !
8174
8175       if (waga_dist.ge.0.0d0) then
8176 !
8177 !          For Gaussian-type Urestr
8178 !
8179         ehomology_constr=(waga_dist*odleg+waga_angle*kat+ &
8180                    waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8181 !     write (iout,*) "ehomology_constr=",ehomology_constr
8182 !         print *, "ok7"
8183       else
8184 !
8185 !          For Lorentzian-type Urestr
8186 !
8187         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+ &
8188                    waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8189 !     write (iout,*) "ehomology_constr=",ehomology_constr
8190          print *, "ok8"
8191       endif
8192 #ifdef DEBUG
8193       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat, &
8194       "Eval",waga_theta,eval, &
8195         "Erot",waga_d,Erot
8196       write (iout,*) "ehomology_constr",ehomology_constr
8197 #endif
8198       return
8199 !
8200 ! FP 01/15 end
8201 !
8202   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8203   747 format(a12,i4,i4,i4,f8.3,f8.3)
8204   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8205   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8206   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X, &
8207             f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8208       end subroutine e_modeller
8209
8210 !----------------------------------------------------------------------------
8211       subroutine ebend_kcc(etheta)
8212       logical lprn
8213       double precision thybt1(maxang_kcc),etheta
8214       integer :: i,iti,j,ihelp
8215       real (kind=8) :: sinthet,costhet,sumth1thyb,gradthybt1
8216 !C Set lprn=.true. for debugging
8217       lprn=energy_dec
8218 !c     lprn=.true.
8219 !C      print *,"wchodze kcc"
8220       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8221       etheta=0.0D0
8222       do i=ithet_start,ithet_end
8223 !c        print *,i,itype(i-1),itype(i),itype(i-2)
8224         if ((itype(i-1,1).eq.ntyp1).or.itype(i-2,1).eq.ntyp1 &
8225        .or.itype(i,1).eq.ntyp1) cycle
8226         iti=iabs(itortyp(itype(i-1,1)))
8227         sinthet=dsin(theta(i))
8228         costhet=dcos(theta(i))
8229         do j=1,nbend_kcc_Tb(iti)
8230           thybt1(j)=v1bend_chyb(j,iti)
8231         enddo
8232         sumth1thyb=v1bend_chyb(0,iti)+ &
8233          tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8234         if (lprn) write (iout,*) i-1,itype(i-1,1),iti,theta(i)*rad2deg,&
8235          sumth1thyb
8236         ihelp=nbend_kcc_Tb(iti)-1
8237         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8238         etheta=etheta+sumth1thyb
8239 !C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8240         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8241       enddo
8242       return
8243       end subroutine ebend_kcc
8244 !c------------
8245 !c-------------------------------------------------------------------------------------
8246       subroutine etheta_constr(ethetacnstr)
8247       real (kind=8) :: ethetacnstr,thetiii,difi
8248       integer :: i,itheta
8249       ethetacnstr=0.0d0
8250 !C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8251       do i=ithetaconstr_start,ithetaconstr_end
8252         itheta=itheta_constr(i)
8253         thetiii=theta(itheta)
8254         difi=pinorm(thetiii-theta_constr0(i))
8255         if (difi.gt.theta_drange(i)) then
8256           difi=difi-theta_drange(i)
8257           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8258           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
8259          +for_thet_constr(i)*difi**3
8260         else if (difi.lt.-drange(i)) then
8261           difi=difi+drange(i)
8262           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8263           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
8264           +for_thet_constr(i)*difi**3
8265         else
8266           difi=0.0
8267         endif
8268        if (energy_dec) then
8269         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",&
8270          i,itheta,rad2deg*thetiii,&
8271          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),&
8272          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,&
8273          gloc(itheta+nphi-2,icg)
8274         endif
8275       enddo
8276       return
8277       end subroutine etheta_constr
8278
8279 !-----------------------------------------------------------------------------
8280       subroutine eback_sc_corr(esccor)
8281 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
8282 !        conformational states; temporarily implemented as differences
8283 !        between UNRES torsional potentials (dependent on three types of
8284 !        residues) and the torsional potentials dependent on all 20 types
8285 !        of residues computed from AM1  energy surfaces of terminally-blocked
8286 !        amino-acid residues.
8287 !      implicit real*8 (a-h,o-z)
8288 !      include 'DIMENSIONS'
8289 !      include 'COMMON.VAR'
8290 !      include 'COMMON.GEO'
8291 !      include 'COMMON.LOCAL'
8292 !      include 'COMMON.TORSION'
8293 !      include 'COMMON.SCCOR'
8294 !      include 'COMMON.INTERACT'
8295 !      include 'COMMON.DERIV'
8296 !      include 'COMMON.CHAIN'
8297 !      include 'COMMON.NAMES'
8298 !      include 'COMMON.IOUNITS'
8299 !      include 'COMMON.FFIELD'
8300 !      include 'COMMON.CONTROL'
8301       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
8302                    cosphi,sinphi
8303       logical :: lprn
8304       integer :: i,interty,j,isccori,isccori1,intertyp
8305 ! Set lprn=.true. for debugging
8306       lprn=.false.
8307 !      lprn=.true.
8308 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8309       esccor=0.0D0
8310       do i=itau_start,itau_end
8311         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
8312         esccor_ii=0.0D0
8313         isccori=isccortyp(itype(i-2,1))
8314         isccori1=isccortyp(itype(i-1,1))
8315
8316 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8317         phii=phi(i)
8318         do intertyp=1,3 !intertyp
8319          esccor_ii=0.0D0
8320 !c Added 09 May 2012 (Adasko)
8321 !c  Intertyp means interaction type of backbone mainchain correlation:
8322 !   1 = SC...Ca...Ca...Ca
8323 !   2 = Ca...Ca...Ca...SC
8324 !   3 = SC...Ca...Ca...SCi
8325         gloci=0.0D0
8326         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
8327             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
8328             (itype(i-1,1).eq.ntyp1))) &
8329           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
8330            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
8331            .or.(itype(i,1).eq.ntyp1))) &
8332           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
8333             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
8334             (itype(i-3,1).eq.ntyp1)))) cycle
8335         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
8336         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
8337        cycle
8338        do j=1,nterm_sccor(isccori,isccori1)
8339           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8340           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8341           cosphi=dcos(j*tauangle(intertyp,i))
8342           sinphi=dsin(j*tauangle(intertyp,i))
8343           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
8344           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8345           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8346         enddo
8347         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
8348                                 'esccor',i,intertyp,esccor_ii
8349 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8350         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8351         if (lprn) &
8352         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
8353         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
8354         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
8355         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8356         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8357        enddo !intertyp
8358       enddo
8359
8360       return
8361       end subroutine eback_sc_corr
8362 !-----------------------------------------------------------------------------
8363       subroutine multibody(ecorr)
8364 ! This subroutine calculates multi-body contributions to energy following
8365 ! the idea of Skolnick et al. If side chains I and J make a contact and
8366 ! at the same time side chains I+1 and J+1 make a contact, an extra
8367 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8368 !      implicit real*8 (a-h,o-z)
8369 !      include 'DIMENSIONS'
8370 !      include 'COMMON.IOUNITS'
8371 !      include 'COMMON.DERIV'
8372 !      include 'COMMON.INTERACT'
8373 !      include 'COMMON.CONTACTS'
8374       real(kind=8),dimension(3) :: gx,gx1
8375       logical :: lprn
8376       real(kind=8) :: ecorr
8377       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
8378 ! Set lprn=.true. for debugging
8379       lprn=.false.
8380
8381       if (lprn) then
8382         write (iout,'(a)') 'Contact function values:'
8383         do i=nnt,nct-2
8384           write (iout,'(i2,20(1x,i2,f10.5))') &
8385               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8386         enddo
8387       endif
8388       ecorr=0.0D0
8389
8390 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8391 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8392       do i=nnt,nct
8393         do j=1,3
8394           gradcorr(j,i)=0.0D0
8395           gradxorr(j,i)=0.0D0
8396         enddo
8397       enddo
8398       do i=nnt,nct-2
8399
8400         DO ISHIFT = 3,4
8401
8402         i1=i+ishift
8403         num_conti=num_cont(i)
8404         num_conti1=num_cont(i1)
8405         do jj=1,num_conti
8406           j=jcont(jj,i)
8407           do kk=1,num_conti1
8408             j1=jcont(kk,i1)
8409             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8410 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8411 !d   &                   ' ishift=',ishift
8412 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8413 ! The system gains extra energy.
8414               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8415             endif   ! j1==j+-ishift
8416           enddo     ! kk
8417         enddo       ! jj
8418
8419         ENDDO ! ISHIFT
8420
8421       enddo         ! i
8422       return
8423       end subroutine multibody
8424 !-----------------------------------------------------------------------------
8425       real(kind=8) function esccorr(i,j,k,l,jj,kk)
8426 !      implicit real*8 (a-h,o-z)
8427 !      include 'DIMENSIONS'
8428 !      include 'COMMON.IOUNITS'
8429 !      include 'COMMON.DERIV'
8430 !      include 'COMMON.INTERACT'
8431 !      include 'COMMON.CONTACTS'
8432       real(kind=8),dimension(3) :: gx,gx1
8433       logical :: lprn
8434       integer :: i,j,k,l,jj,kk,m,ll
8435       real(kind=8) :: eij,ekl
8436       lprn=.false.
8437       eij=facont(jj,i)
8438       ekl=facont(kk,k)
8439 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8440 ! Calculate the multi-body contribution to energy.
8441 ! Calculate multi-body contributions to the gradient.
8442 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8443 !d   & k,l,(gacont(m,kk,k),m=1,3)
8444       do m=1,3
8445         gx(m) =ekl*gacont(m,jj,i)
8446         gx1(m)=eij*gacont(m,kk,k)
8447         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8448         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8449         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8450         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8451       enddo
8452       do m=i,j-1
8453         do ll=1,3
8454           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8455         enddo
8456       enddo
8457       do m=k,l-1
8458         do ll=1,3
8459           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8460         enddo
8461       enddo
8462       esccorr=-eij*ekl
8463       return
8464       end function esccorr
8465 !-----------------------------------------------------------------------------
8466       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8467 ! This subroutine calculates multi-body contributions to hydrogen-bonding
8468 !      implicit real*8 (a-h,o-z)
8469 !      include 'DIMENSIONS'
8470 !      include 'COMMON.IOUNITS'
8471 #ifdef MPI
8472       include "mpif.h"
8473 !      integer :: maxconts !max_cont=maxconts  =nres/4
8474       integer,parameter :: max_dim=26
8475       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8476       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8477 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
8478 !el      common /przechowalnia/ zapas
8479       integer :: status(MPI_STATUS_SIZE)
8480       integer,dimension((nres/4)*2) :: req !maxconts*2
8481       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
8482 #endif
8483 !      include 'COMMON.SETUP'
8484 !      include 'COMMON.FFIELD'
8485 !      include 'COMMON.DERIV'
8486 !      include 'COMMON.INTERACT'
8487 !      include 'COMMON.CONTACTS'
8488 !      include 'COMMON.CONTROL'
8489 !      include 'COMMON.LOCAL'
8490       real(kind=8),dimension(3) :: gx,gx1
8491       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
8492       logical :: lprn,ldone
8493 !el local variables
8494       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
8495               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
8496
8497 ! Set lprn=.true. for debugging
8498       lprn=.false.
8499 #ifdef MPI
8500 !      maxconts=nres/4
8501       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
8502       n_corr=0
8503       n_corr1=0
8504       if (nfgtasks.le.1) goto 30
8505       if (lprn) then
8506         write (iout,'(a)') 'Contact function values before RECEIVE:'
8507         do i=nnt,nct-2
8508           write (iout,'(2i3,50(1x,i2,f5.2))') &
8509           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8510           j=1,num_cont_hb(i))
8511         enddo
8512       endif
8513       call flush(iout)
8514       do i=1,ntask_cont_from
8515         ncont_recv(i)=0
8516       enddo
8517       do i=1,ntask_cont_to
8518         ncont_sent(i)=0
8519       enddo
8520 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8521 !     & ntask_cont_to
8522 ! Make the list of contacts to send to send to other procesors
8523 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8524 !      call flush(iout)
8525       do i=iturn3_start,iturn3_end
8526 !        write (iout,*) "make contact list turn3",i," num_cont",
8527 !     &    num_cont_hb(i)
8528         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8529       enddo
8530       do i=iturn4_start,iturn4_end
8531 !        write (iout,*) "make contact list turn4",i," num_cont",
8532 !     &   num_cont_hb(i)
8533         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8534       enddo
8535       do ii=1,nat_sent
8536         i=iat_sent(ii)
8537 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8538 !     &    num_cont_hb(i)
8539         do j=1,num_cont_hb(i)
8540         do k=1,4
8541           jjc=jcont_hb(j,i)
8542           iproc=iint_sent_local(k,jjc,ii)
8543 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8544           if (iproc.gt.0) then
8545             ncont_sent(iproc)=ncont_sent(iproc)+1
8546             nn=ncont_sent(iproc)
8547             zapas(1,nn,iproc)=i
8548             zapas(2,nn,iproc)=jjc
8549             zapas(3,nn,iproc)=facont_hb(j,i)
8550             zapas(4,nn,iproc)=ees0p(j,i)
8551             zapas(5,nn,iproc)=ees0m(j,i)
8552             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8553             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8554             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8555             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8556             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8557             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8558             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8559             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8560             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8561             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8562             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8563             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8564             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8565             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8566             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8567             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8568             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8569             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8570             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8571             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8572             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8573           endif
8574         enddo
8575         enddo
8576       enddo
8577       if (lprn) then
8578       write (iout,*) &
8579         "Numbers of contacts to be sent to other processors",&
8580         (ncont_sent(i),i=1,ntask_cont_to)
8581       write (iout,*) "Contacts sent"
8582       do ii=1,ntask_cont_to
8583         nn=ncont_sent(ii)
8584         iproc=itask_cont_to(ii)
8585         write (iout,*) nn," contacts to processor",iproc,&
8586          " of CONT_TO_COMM group"
8587         do i=1,nn
8588           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8589         enddo
8590       enddo
8591       call flush(iout)
8592       endif
8593       CorrelType=477
8594       CorrelID=fg_rank+1
8595       CorrelType1=478
8596       CorrelID1=nfgtasks+fg_rank+1
8597       ireq=0
8598 ! Receive the numbers of needed contacts from other processors
8599       do ii=1,ntask_cont_from
8600         iproc=itask_cont_from(ii)
8601         ireq=ireq+1
8602         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8603           FG_COMM,req(ireq),IERR)
8604       enddo
8605 !      write (iout,*) "IRECV ended"
8606 !      call flush(iout)
8607 ! Send the number of contacts needed by other processors
8608       do ii=1,ntask_cont_to
8609         iproc=itask_cont_to(ii)
8610         ireq=ireq+1
8611         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8612           FG_COMM,req(ireq),IERR)
8613       enddo
8614 !      write (iout,*) "ISEND ended"
8615 !      write (iout,*) "number of requests (nn)",ireq
8616       call flush(iout)
8617       if (ireq.gt.0) &
8618         call MPI_Waitall(ireq,req,status_array,ierr)
8619 !      write (iout,*)
8620 !     &  "Numbers of contacts to be received from other processors",
8621 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8622 !      call flush(iout)
8623 ! Receive contacts
8624       ireq=0
8625       do ii=1,ntask_cont_from
8626         iproc=itask_cont_from(ii)
8627         nn=ncont_recv(ii)
8628 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8629 !     &   " of CONT_TO_COMM group"
8630         call flush(iout)
8631         if (nn.gt.0) then
8632           ireq=ireq+1
8633           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
8634           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8635 !          write (iout,*) "ireq,req",ireq,req(ireq)
8636         endif
8637       enddo
8638 ! Send the contacts to processors that need them
8639       do ii=1,ntask_cont_to
8640         iproc=itask_cont_to(ii)
8641         nn=ncont_sent(ii)
8642 !        write (iout,*) nn," contacts to processor",iproc,
8643 !     &   " of CONT_TO_COMM group"
8644         if (nn.gt.0) then
8645           ireq=ireq+1
8646           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8647             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8648 !          write (iout,*) "ireq,req",ireq,req(ireq)
8649 !          do i=1,nn
8650 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8651 !          enddo
8652         endif
8653       enddo
8654 !      write (iout,*) "number of requests (contacts)",ireq
8655 !      write (iout,*) "req",(req(i),i=1,4)
8656 !      call flush(iout)
8657       if (ireq.gt.0) &
8658        call MPI_Waitall(ireq,req,status_array,ierr)
8659       do iii=1,ntask_cont_from
8660         iproc=itask_cont_from(iii)
8661         nn=ncont_recv(iii)
8662         if (lprn) then
8663         write (iout,*) "Received",nn," contacts from processor",iproc,&
8664          " of CONT_FROM_COMM group"
8665         call flush(iout)
8666         do i=1,nn
8667           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8668         enddo
8669         call flush(iout)
8670         endif
8671         do i=1,nn
8672           ii=zapas_recv(1,i,iii)
8673 ! Flag the received contacts to prevent double-counting
8674           jj=-zapas_recv(2,i,iii)
8675 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8676 !          call flush(iout)
8677           nnn=num_cont_hb(ii)+1
8678           num_cont_hb(ii)=nnn
8679           jcont_hb(nnn,ii)=jj
8680           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8681           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8682           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8683           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8684           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8685           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8686           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8687           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8688           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8689           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8690           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8691           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8692           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8693           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8694           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8695           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8696           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8697           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8698           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8699           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8700           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8701           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8702           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8703           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8704         enddo
8705       enddo
8706       call flush(iout)
8707       if (lprn) then
8708         write (iout,'(a)') 'Contact function values after receive:'
8709         do i=nnt,nct-2
8710           write (iout,'(2i3,50(1x,i3,f5.2))') &
8711           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8712           j=1,num_cont_hb(i))
8713         enddo
8714         call flush(iout)
8715       endif
8716    30 continue
8717 #endif
8718       if (lprn) then
8719         write (iout,'(a)') 'Contact function values:'
8720         do i=nnt,nct-2
8721           write (iout,'(2i3,50(1x,i3,f5.2))') &
8722           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8723           j=1,num_cont_hb(i))
8724         enddo
8725       endif
8726       ecorr=0.0D0
8727
8728 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8729 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8730 ! Remove the loop below after debugging !!!
8731       do i=nnt,nct
8732         do j=1,3
8733           gradcorr(j,i)=0.0D0
8734           gradxorr(j,i)=0.0D0
8735         enddo
8736       enddo
8737 ! Calculate the local-electrostatic correlation terms
8738       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8739         i1=i+1
8740         num_conti=num_cont_hb(i)
8741         num_conti1=num_cont_hb(i+1)
8742         do jj=1,num_conti
8743           j=jcont_hb(jj,i)
8744           jp=iabs(j)
8745           do kk=1,num_conti1
8746             j1=jcont_hb(kk,i1)
8747             jp1=iabs(j1)
8748 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
8749 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
8750             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8751                 .or. j.lt.0 .and. j1.gt.0) .and. &
8752                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8753 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8754 ! The system gains extra energy.
8755               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8756               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
8757                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8758               n_corr=n_corr+1
8759             else if (j1.eq.j) then
8760 ! Contacts I-J and I-(J+1) occur simultaneously.
8761 ! The system loses extra energy.
8762 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8763             endif
8764           enddo ! kk
8765           do kk=1,num_conti
8766             j1=jcont_hb(kk,i)
8767 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8768 !    &         ' jj=',jj,' kk=',kk
8769             if (j1.eq.j+1) then
8770 ! Contacts I-J and (I+1)-J occur simultaneously.
8771 ! The system loses extra energy.
8772 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8773             endif ! j1==j+1
8774           enddo ! kk
8775         enddo ! jj
8776       enddo ! i
8777       return
8778       end subroutine multibody_hb
8779 !-----------------------------------------------------------------------------
8780       subroutine add_hb_contact(ii,jj,itask)
8781 !      implicit real*8 (a-h,o-z)
8782 !      include "DIMENSIONS"
8783 !      include "COMMON.IOUNITS"
8784 !      include "COMMON.CONTACTS"
8785 !      integer,parameter :: maxconts=nres/4
8786       integer,parameter :: max_dim=26
8787       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8788 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
8789 !      common /przechowalnia/ zapas
8790       integer :: i,j,ii,jj,iproc,nn,jjc
8791       integer,dimension(4) :: itask
8792 !      write (iout,*) "itask",itask
8793       do i=1,2
8794         iproc=itask(i)
8795         if (iproc.gt.0) then
8796           do j=1,num_cont_hb(ii)
8797             jjc=jcont_hb(j,ii)
8798 !            write (iout,*) "i",ii," j",jj," jjc",jjc
8799             if (jjc.eq.jj) then
8800               ncont_sent(iproc)=ncont_sent(iproc)+1
8801               nn=ncont_sent(iproc)
8802               zapas(1,nn,iproc)=ii
8803               zapas(2,nn,iproc)=jjc
8804               zapas(3,nn,iproc)=facont_hb(j,ii)
8805               zapas(4,nn,iproc)=ees0p(j,ii)
8806               zapas(5,nn,iproc)=ees0m(j,ii)
8807               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8808               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8809               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8810               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8811               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8812               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8813               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8814               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8815               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8816               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8817               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8818               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8819               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8820               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8821               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8822               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8823               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8824               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8825               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8826               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8827               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8828               exit
8829             endif
8830           enddo
8831         endif
8832       enddo
8833       return
8834       end subroutine add_hb_contact
8835 !-----------------------------------------------------------------------------
8836       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
8837 ! This subroutine calculates multi-body contributions to hydrogen-bonding
8838 !      implicit real*8 (a-h,o-z)
8839 !      include 'DIMENSIONS'
8840 !      include 'COMMON.IOUNITS'
8841       integer,parameter :: max_dim=70
8842 #ifdef MPI
8843       include "mpif.h"
8844 !      integer :: maxconts !max_cont=maxconts=nres/4
8845       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8846       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8847 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8848 !      common /przechowalnia/ zapas
8849       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
8850         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
8851         ierr,iii,nnn
8852 #endif
8853 !      include 'COMMON.SETUP'
8854 !      include 'COMMON.FFIELD'
8855 !      include 'COMMON.DERIV'
8856 !      include 'COMMON.LOCAL'
8857 !      include 'COMMON.INTERACT'
8858 !      include 'COMMON.CONTACTS'
8859 !      include 'COMMON.CHAIN'
8860 !      include 'COMMON.CONTROL'
8861       real(kind=8),dimension(3) :: gx,gx1
8862       integer,dimension(nres) :: num_cont_hb_old
8863       logical :: lprn,ldone
8864 !EL      double precision eello4,eello5,eelo6,eello_turn6
8865 !EL      external eello4,eello5,eello6,eello_turn6
8866 !el local variables
8867       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
8868               j1,jp1,i1,num_conti1
8869       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
8870       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
8871
8872 ! Set lprn=.true. for debugging
8873       lprn=.false.
8874       eturn6=0.0d0
8875 #ifdef MPI
8876 !      maxconts=nres/4
8877       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
8878       do i=1,nres
8879         num_cont_hb_old(i)=num_cont_hb(i)
8880       enddo
8881       n_corr=0
8882       n_corr1=0
8883       if (nfgtasks.le.1) goto 30
8884       if (lprn) then
8885         write (iout,'(a)') 'Contact function values before RECEIVE:'
8886         do i=nnt,nct-2
8887           write (iout,'(2i3,50(1x,i2,f5.2))') &
8888           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8889           j=1,num_cont_hb(i))
8890         enddo
8891       endif
8892       call flush(iout)
8893       do i=1,ntask_cont_from
8894         ncont_recv(i)=0
8895       enddo
8896       do i=1,ntask_cont_to
8897         ncont_sent(i)=0
8898       enddo
8899 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8900 !     & ntask_cont_to
8901 ! Make the list of contacts to send to send to other procesors
8902       do i=iturn3_start,iturn3_end
8903 !        write (iout,*) "make contact list turn3",i," num_cont",
8904 !     &    num_cont_hb(i)
8905         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8906       enddo
8907       do i=iturn4_start,iturn4_end
8908 !        write (iout,*) "make contact list turn4",i," num_cont",
8909 !     &   num_cont_hb(i)
8910         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8911       enddo
8912       do ii=1,nat_sent
8913         i=iat_sent(ii)
8914 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8915 !     &    num_cont_hb(i)
8916         do j=1,num_cont_hb(i)
8917         do k=1,4
8918           jjc=jcont_hb(j,i)
8919           iproc=iint_sent_local(k,jjc,ii)
8920 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8921           if (iproc.ne.0) then
8922             ncont_sent(iproc)=ncont_sent(iproc)+1
8923             nn=ncont_sent(iproc)
8924             zapas(1,nn,iproc)=i
8925             zapas(2,nn,iproc)=jjc
8926             zapas(3,nn,iproc)=d_cont(j,i)
8927             ind=3
8928             do kk=1,3
8929               ind=ind+1
8930               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8931             enddo
8932             do kk=1,2
8933               do ll=1,2
8934                 ind=ind+1
8935                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8936               enddo
8937             enddo
8938             do jj=1,5
8939               do kk=1,3
8940                 do ll=1,2
8941                   do mm=1,2
8942                     ind=ind+1
8943                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8944                   enddo
8945                 enddo
8946               enddo
8947             enddo
8948           endif
8949         enddo
8950         enddo
8951       enddo
8952       if (lprn) then
8953       write (iout,*) &
8954         "Numbers of contacts to be sent to other processors",&
8955         (ncont_sent(i),i=1,ntask_cont_to)
8956       write (iout,*) "Contacts sent"
8957       do ii=1,ntask_cont_to
8958         nn=ncont_sent(ii)
8959         iproc=itask_cont_to(ii)
8960         write (iout,*) nn," contacts to processor",iproc,&
8961          " of CONT_TO_COMM group"
8962         do i=1,nn
8963           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8964         enddo
8965       enddo
8966       call flush(iout)
8967       endif
8968       CorrelType=477
8969       CorrelID=fg_rank+1
8970       CorrelType1=478
8971       CorrelID1=nfgtasks+fg_rank+1
8972       ireq=0
8973 ! Receive the numbers of needed contacts from other processors
8974       do ii=1,ntask_cont_from
8975         iproc=itask_cont_from(ii)
8976         ireq=ireq+1
8977         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8978           FG_COMM,req(ireq),IERR)
8979       enddo
8980 !      write (iout,*) "IRECV ended"
8981 !      call flush(iout)
8982 ! Send the number of contacts needed by other processors
8983       do ii=1,ntask_cont_to
8984         iproc=itask_cont_to(ii)
8985         ireq=ireq+1
8986         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8987           FG_COMM,req(ireq),IERR)
8988       enddo
8989 !      write (iout,*) "ISEND ended"
8990 !      write (iout,*) "number of requests (nn)",ireq
8991       call flush(iout)
8992       if (ireq.gt.0) &
8993         call MPI_Waitall(ireq,req,status_array,ierr)
8994 !      write (iout,*)
8995 !     &  "Numbers of contacts to be received from other processors",
8996 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8997 !      call flush(iout)
8998 ! Receive contacts
8999       ireq=0
9000       do ii=1,ntask_cont_from
9001         iproc=itask_cont_from(ii)
9002         nn=ncont_recv(ii)
9003 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9004 !     &   " of CONT_TO_COMM group"
9005         call flush(iout)
9006         if (nn.gt.0) then
9007           ireq=ireq+1
9008           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
9009           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9010 !          write (iout,*) "ireq,req",ireq,req(ireq)
9011         endif
9012       enddo
9013 ! Send the contacts to processors that need them
9014       do ii=1,ntask_cont_to
9015         iproc=itask_cont_to(ii)
9016         nn=ncont_sent(ii)
9017 !        write (iout,*) nn," contacts to processor",iproc,
9018 !     &   " of CONT_TO_COMM group"
9019         if (nn.gt.0) then
9020           ireq=ireq+1
9021           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
9022             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9023 !          write (iout,*) "ireq,req",ireq,req(ireq)
9024 !          do i=1,nn
9025 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9026 !          enddo
9027         endif
9028       enddo
9029 !      write (iout,*) "number of requests (contacts)",ireq
9030 !      write (iout,*) "req",(req(i),i=1,4)
9031 !      call flush(iout)
9032       if (ireq.gt.0) &
9033        call MPI_Waitall(ireq,req,status_array,ierr)
9034       do iii=1,ntask_cont_from
9035         iproc=itask_cont_from(iii)
9036         nn=ncont_recv(iii)
9037         if (lprn) then
9038         write (iout,*) "Received",nn," contacts from processor",iproc,&
9039          " of CONT_FROM_COMM group"
9040         call flush(iout)
9041         do i=1,nn
9042           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9043         enddo
9044         call flush(iout)
9045         endif
9046         do i=1,nn
9047           ii=zapas_recv(1,i,iii)
9048 ! Flag the received contacts to prevent double-counting
9049           jj=-zapas_recv(2,i,iii)
9050 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9051 !          call flush(iout)
9052           nnn=num_cont_hb(ii)+1
9053           num_cont_hb(ii)=nnn
9054           jcont_hb(nnn,ii)=jj
9055           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9056           ind=3
9057           do kk=1,3
9058             ind=ind+1
9059             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9060           enddo
9061           do kk=1,2
9062             do ll=1,2
9063               ind=ind+1
9064               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9065             enddo
9066           enddo
9067           do jj=1,5
9068             do kk=1,3
9069               do ll=1,2
9070                 do mm=1,2
9071                   ind=ind+1
9072                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9073                 enddo
9074               enddo
9075             enddo
9076           enddo
9077         enddo
9078       enddo
9079       call flush(iout)
9080       if (lprn) then
9081         write (iout,'(a)') 'Contact function values after receive:'
9082         do i=nnt,nct-2
9083           write (iout,'(2i3,50(1x,i3,5f6.3))') &
9084           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
9085           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9086         enddo
9087         call flush(iout)
9088       endif
9089    30 continue
9090 #endif
9091       if (lprn) then
9092         write (iout,'(a)') 'Contact function values:'
9093         do i=nnt,nct-2
9094           write (iout,'(2i3,50(1x,i2,5f6.3))') &
9095           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
9096           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9097         enddo
9098       endif
9099       ecorr=0.0D0
9100       ecorr5=0.0d0
9101       ecorr6=0.0d0
9102
9103 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
9104 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
9105 ! Remove the loop below after debugging !!!
9106       do i=nnt,nct
9107         do j=1,3
9108           gradcorr(j,i)=0.0D0
9109           gradxorr(j,i)=0.0D0
9110         enddo
9111       enddo
9112 ! Calculate the dipole-dipole interaction energies
9113       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9114       do i=iatel_s,iatel_e+1
9115         num_conti=num_cont_hb(i)
9116         do jj=1,num_conti
9117           j=jcont_hb(jj,i)
9118 #ifdef MOMENT
9119           call dipole(i,j,jj)
9120 #endif
9121         enddo
9122       enddo
9123       endif
9124 ! Calculate the local-electrostatic correlation terms
9125 !                write (iout,*) "gradcorr5 in eello5 before loop"
9126 !                do iii=1,nres
9127 !                  write (iout,'(i5,3f10.5)')
9128 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9129 !                enddo
9130       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9131 !        write (iout,*) "corr loop i",i
9132         i1=i+1
9133         num_conti=num_cont_hb(i)
9134         num_conti1=num_cont_hb(i+1)
9135         do jj=1,num_conti
9136           j=jcont_hb(jj,i)
9137           jp=iabs(j)
9138           do kk=1,num_conti1
9139             j1=jcont_hb(kk,i1)
9140             jp1=iabs(j1)
9141 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9142 !     &         ' jj=',jj,' kk=',kk
9143 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
9144             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
9145                 .or. j.lt.0 .and. j1.gt.0) .and. &
9146                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9147 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9148 ! The system gains extra energy.
9149               n_corr=n_corr+1
9150               sqd1=dsqrt(d_cont(jj,i))
9151               sqd2=dsqrt(d_cont(kk,i1))
9152               sred_geom = sqd1*sqd2
9153               IF (sred_geom.lt.cutoff_corr) THEN
9154                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
9155                   ekont,fprimcont)
9156 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9157 !d     &         ' jj=',jj,' kk=',kk
9158                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9159                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9160                 do l=1,3
9161                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9162                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9163                 enddo
9164                 n_corr1=n_corr1+1
9165 !d               write (iout,*) 'sred_geom=',sred_geom,
9166 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
9167 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9168 !d               write (iout,*) "g_contij",g_contij
9169 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9170 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9171                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9172                 if (wcorr4.gt.0.0d0) &
9173                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9174                   if (energy_dec.and.wcorr4.gt.0.0d0) &
9175                        write (iout,'(a6,4i5,0pf7.3)') &
9176                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9177 !                write (iout,*) "gradcorr5 before eello5"
9178 !                do iii=1,nres
9179 !                  write (iout,'(i5,3f10.5)')
9180 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9181 !                enddo
9182                 if (wcorr5.gt.0.0d0) &
9183                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9184 !                write (iout,*) "gradcorr5 after eello5"
9185 !                do iii=1,nres
9186 !                  write (iout,'(i5,3f10.5)')
9187 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9188 !                enddo
9189                   if (energy_dec.and.wcorr5.gt.0.0d0) &
9190                        write (iout,'(a6,4i5,0pf7.3)') &
9191                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9192 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9193 !d                write(2,*)'ijkl',i,jp,i+1,jp1
9194                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
9195                      .or. wturn6.eq.0.0d0))then
9196 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9197                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9198                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
9199                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9200 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9201 !d     &            'ecorr6=',ecorr6
9202 !d                write (iout,'(4e15.5)') sred_geom,
9203 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9204 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9205 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9206                 else if (wturn6.gt.0.0d0 &
9207                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9208 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9209                   eturn6=eturn6+eello_turn6(i,jj,kk)
9210                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
9211                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9212 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
9213                 endif
9214               ENDIF
9215 1111          continue
9216             endif
9217           enddo ! kk
9218         enddo ! jj
9219       enddo ! i
9220       do i=1,nres
9221         num_cont_hb(i)=num_cont_hb_old(i)
9222       enddo
9223 !                write (iout,*) "gradcorr5 in eello5"
9224 !                do iii=1,nres
9225 !                  write (iout,'(i5,3f10.5)')
9226 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9227 !                enddo
9228       return
9229       end subroutine multibody_eello
9230 !-----------------------------------------------------------------------------
9231       subroutine add_hb_contact_eello(ii,jj,itask)
9232 !      implicit real*8 (a-h,o-z)
9233 !      include "DIMENSIONS"
9234 !      include "COMMON.IOUNITS"
9235 !      include "COMMON.CONTACTS"
9236 !      integer,parameter :: maxconts=nres/4
9237       integer,parameter :: max_dim=70
9238       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
9239 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
9240 !      common /przechowalnia/ zapas
9241
9242       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
9243       integer,dimension(4) ::itask
9244 !      write (iout,*) "itask",itask
9245       do i=1,2
9246         iproc=itask(i)
9247         if (iproc.gt.0) then
9248           do j=1,num_cont_hb(ii)
9249             jjc=jcont_hb(j,ii)
9250 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9251             if (jjc.eq.jj) then
9252               ncont_sent(iproc)=ncont_sent(iproc)+1
9253               nn=ncont_sent(iproc)
9254               zapas(1,nn,iproc)=ii
9255               zapas(2,nn,iproc)=jjc
9256               zapas(3,nn,iproc)=d_cont(j,ii)
9257               ind=3
9258               do kk=1,3
9259                 ind=ind+1
9260                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9261               enddo
9262               do kk=1,2
9263                 do ll=1,2
9264                   ind=ind+1
9265                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9266                 enddo
9267               enddo
9268               do jj=1,5
9269                 do kk=1,3
9270                   do ll=1,2
9271                     do mm=1,2
9272                       ind=ind+1
9273                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9274                     enddo
9275                   enddo
9276                 enddo
9277               enddo
9278               exit
9279             endif
9280           enddo
9281         endif
9282       enddo
9283       return
9284       end subroutine add_hb_contact_eello
9285 !-----------------------------------------------------------------------------
9286       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9287 !      implicit real*8 (a-h,o-z)
9288 !      include 'DIMENSIONS'
9289 !      include 'COMMON.IOUNITS'
9290 !      include 'COMMON.DERIV'
9291 !      include 'COMMON.INTERACT'
9292 !      include 'COMMON.CONTACTS'
9293       real(kind=8),dimension(3) :: gx,gx1
9294       logical :: lprn
9295 !el local variables
9296       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
9297       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
9298                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
9299                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
9300                    rlocshield
9301
9302       lprn=.false.
9303       eij=facont_hb(jj,i)
9304       ekl=facont_hb(kk,k)
9305       ees0pij=ees0p(jj,i)
9306       ees0pkl=ees0p(kk,k)
9307       ees0mij=ees0m(jj,i)
9308       ees0mkl=ees0m(kk,k)
9309       ekont=eij*ekl
9310       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9311 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9312 ! Following 4 lines for diagnostics.
9313 !d    ees0pkl=0.0D0
9314 !d    ees0pij=1.0D0
9315 !d    ees0mkl=0.0D0
9316 !d    ees0mij=1.0D0
9317 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9318 !     & 'Contacts ',i,j,
9319 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9320 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9321 !     & 'gradcorr_long'
9322 ! Calculate the multi-body contribution to energy.
9323 !      ecorr=ecorr+ekont*ees
9324 ! Calculate multi-body contributions to the gradient.
9325       coeffpees0pij=coeffp*ees0pij
9326       coeffmees0mij=coeffm*ees0mij
9327       coeffpees0pkl=coeffp*ees0pkl
9328       coeffmees0mkl=coeffm*ees0mkl
9329       do ll=1,3
9330 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9331         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
9332         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
9333         coeffmees0mkl*gacontm_hb1(ll,jj,i))
9334         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
9335         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
9336         coeffmees0mkl*gacontm_hb2(ll,jj,i))
9337 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9338         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
9339         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
9340         coeffmees0mij*gacontm_hb1(ll,kk,k))
9341         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
9342         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
9343         coeffmees0mij*gacontm_hb2(ll,kk,k))
9344         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
9345            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
9346            coeffmees0mkl*gacontm_hb3(ll,jj,i))
9347         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9348         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9349         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
9350            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
9351            coeffmees0mij*gacontm_hb3(ll,kk,k))
9352         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9353         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9354 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9355       enddo
9356 !      write (iout,*)
9357 !grad      do m=i+1,j-1
9358 !grad        do ll=1,3
9359 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
9360 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9361 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9362 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9363 !grad        enddo
9364 !grad      enddo
9365 !grad      do m=k+1,l-1
9366 !grad        do ll=1,3
9367 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
9368 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
9369 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9370 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9371 !grad        enddo
9372 !grad      enddo
9373 !      write (iout,*) "ehbcorr",ekont*ees
9374       ehbcorr=ekont*ees
9375       if (shield_mode.gt.0) then
9376        j=ees0plist(jj,i)
9377        l=ees0plist(kk,k)
9378 !C        print *,i,j,fac_shield(i),fac_shield(j),
9379 !C     &fac_shield(k),fac_shield(l)
9380         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
9381            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9382           do ilist=1,ishield_list(i)
9383            iresshield=shield_list(ilist,i)
9384            do m=1,3
9385            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9386            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
9387                    rlocshield  &
9388             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9389             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
9390             +rlocshield
9391            enddo
9392           enddo
9393           do ilist=1,ishield_list(j)
9394            iresshield=shield_list(ilist,j)
9395            do m=1,3
9396            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9397            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
9398                    rlocshield &
9399             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9400            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
9401             +rlocshield
9402            enddo
9403           enddo
9404
9405           do ilist=1,ishield_list(k)
9406            iresshield=shield_list(ilist,k)
9407            do m=1,3
9408            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9409            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
9410                    rlocshield &
9411             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9412            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
9413             +rlocshield
9414            enddo
9415           enddo
9416           do ilist=1,ishield_list(l)
9417            iresshield=shield_list(ilist,l)
9418            do m=1,3
9419            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9420            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
9421                    rlocshield &
9422             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9423            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
9424             +rlocshield
9425            enddo
9426           enddo
9427           do m=1,3
9428             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
9429                    grad_shield(m,i)*ehbcorr/fac_shield(i)
9430             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
9431                    grad_shield(m,j)*ehbcorr/fac_shield(j)
9432             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
9433                    grad_shield(m,i)*ehbcorr/fac_shield(i)
9434             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
9435                    grad_shield(m,j)*ehbcorr/fac_shield(j)
9436
9437             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
9438                    grad_shield(m,k)*ehbcorr/fac_shield(k)
9439             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
9440                    grad_shield(m,l)*ehbcorr/fac_shield(l)
9441             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
9442                    grad_shield(m,k)*ehbcorr/fac_shield(k)
9443             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
9444                    grad_shield(m,l)*ehbcorr/fac_shield(l)
9445
9446            enddo
9447       endif
9448       endif
9449       return
9450       end function ehbcorr
9451 #ifdef MOMENT
9452 !-----------------------------------------------------------------------------
9453       subroutine dipole(i,j,jj)
9454 !      implicit real*8 (a-h,o-z)
9455 !      include 'DIMENSIONS'
9456 !      include 'COMMON.IOUNITS'
9457 !      include 'COMMON.CHAIN'
9458 !      include 'COMMON.FFIELD'
9459 !      include 'COMMON.DERIV'
9460 !      include 'COMMON.INTERACT'
9461 !      include 'COMMON.CONTACTS'
9462 !      include 'COMMON.TORSION'
9463 !      include 'COMMON.VAR'
9464 !      include 'COMMON.GEO'
9465       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
9466       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
9467       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
9468
9469       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
9470       allocate(dipderx(3,5,4,maxconts,nres))
9471 !
9472
9473       iti1 = itortyp(itype(i+1,1))
9474       if (j.lt.nres-1) then
9475         itj1 = itype2loc(itype(j+1,1))
9476       else
9477         itj1=nloctyp
9478       endif
9479       do iii=1,2
9480         dipi(iii,1)=Ub2(iii,i)
9481         dipderi(iii)=Ub2der(iii,i)
9482         dipi(iii,2)=b1(iii,iti1)
9483         dipj(iii,1)=Ub2(iii,j)
9484         dipderj(iii)=Ub2der(iii,j)
9485         dipj(iii,2)=b1(iii,itj1)
9486       enddo
9487       kkk=0
9488       do iii=1,2
9489         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9490         do jjj=1,2
9491           kkk=kkk+1
9492           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9493         enddo
9494       enddo
9495       do kkk=1,5
9496         do lll=1,3
9497           mmm=0
9498           do iii=1,2
9499             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
9500               auxvec(1))
9501             do jjj=1,2
9502               mmm=mmm+1
9503               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9504             enddo
9505           enddo
9506         enddo
9507       enddo
9508       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9509       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9510       do iii=1,2
9511         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9512       enddo
9513       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9514       do iii=1,2
9515         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9516       enddo
9517       return
9518       end subroutine dipole
9519 #endif
9520 !-----------------------------------------------------------------------------
9521       subroutine calc_eello(i,j,k,l,jj,kk)
9522 !
9523 ! This subroutine computes matrices and vectors needed to calculate
9524 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
9525 !
9526       use comm_kut
9527 !      implicit real*8 (a-h,o-z)
9528 !      include 'DIMENSIONS'
9529 !      include 'COMMON.IOUNITS'
9530 !      include 'COMMON.CHAIN'
9531 !      include 'COMMON.DERIV'
9532 !      include 'COMMON.INTERACT'
9533 !      include 'COMMON.CONTACTS'
9534 !      include 'COMMON.TORSION'
9535 !      include 'COMMON.VAR'
9536 !      include 'COMMON.GEO'
9537 !      include 'COMMON.FFIELD'
9538       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
9539       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
9540       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
9541               itj1
9542 !el      logical :: lprn
9543 !el      common /kutas/ lprn
9544 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9545 !d     & ' jj=',jj,' kk=',kk
9546 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9547 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9548 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9549       do iii=1,2
9550         do jjj=1,2
9551           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9552           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9553         enddo
9554       enddo
9555       call transpose2(aa1(1,1),aa1t(1,1))
9556       call transpose2(aa2(1,1),aa2t(1,1))
9557       do kkk=1,5
9558         do lll=1,3
9559           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
9560             aa1tder(1,1,lll,kkk))
9561           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
9562             aa2tder(1,1,lll,kkk))
9563         enddo
9564       enddo
9565       if (l.eq.j+1) then
9566 ! parallel orientation of the two CA-CA-CA frames.
9567         if (i.gt.1) then
9568           iti=itortyp(itype(i,1))
9569         else
9570           iti=ntortyp+1
9571         endif
9572         itk1=itortyp(itype(k+1,1))
9573         itj=itortyp(itype(j,1))
9574         if (l.lt.nres-1) then
9575           itl1=itortyp(itype(l+1,1))
9576         else
9577           itl1=ntortyp+1
9578         endif
9579 ! A1 kernel(j+1) A2T
9580 !d        do iii=1,2
9581 !d          write (iout,'(3f10.5,5x,3f10.5)')
9582 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9583 !d        enddo
9584         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9585          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
9586          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9587 ! Following matrices are needed only for 6-th order cumulants
9588         IF (wcorr6.gt.0.0d0) THEN
9589         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9590          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
9591          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9592         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9593          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
9594          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9595          ADtEAderx(1,1,1,1,1,1))
9596         lprn=.false.
9597         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9598          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
9599          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9600          ADtEA1derx(1,1,1,1,1,1))
9601         ENDIF
9602 ! End 6-th order cumulants
9603 !d        lprn=.false.
9604 !d        if (lprn) then
9605 !d        write (2,*) 'In calc_eello6'
9606 !d        do iii=1,2
9607 !d          write (2,*) 'iii=',iii
9608 !d          do kkk=1,5
9609 !d            write (2,*) 'kkk=',kkk
9610 !d            do jjj=1,2
9611 !d              write (2,'(3(2f10.5),5x)')
9612 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9613 !d            enddo
9614 !d          enddo
9615 !d        enddo
9616 !d        endif
9617         call transpose2(EUgder(1,1,k),auxmat(1,1))
9618         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9619         call transpose2(EUg(1,1,k),auxmat(1,1))
9620         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9621         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9622         do iii=1,2
9623           do kkk=1,5
9624             do lll=1,3
9625               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9626                 EAEAderx(1,1,lll,kkk,iii,1))
9627             enddo
9628           enddo
9629         enddo
9630 ! A1T kernel(i+1) A2
9631         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9632          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
9633          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9634 ! Following matrices are needed only for 6-th order cumulants
9635         IF (wcorr6.gt.0.0d0) THEN
9636         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9637          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
9638          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9639         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9640          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
9641          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9642          ADtEAderx(1,1,1,1,1,2))
9643         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9644          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
9645          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9646          ADtEA1derx(1,1,1,1,1,2))
9647         ENDIF
9648 ! End 6-th order cumulants
9649         call transpose2(EUgder(1,1,l),auxmat(1,1))
9650         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9651         call transpose2(EUg(1,1,l),auxmat(1,1))
9652         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9653         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9654         do iii=1,2
9655           do kkk=1,5
9656             do lll=1,3
9657               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9658                 EAEAderx(1,1,lll,kkk,iii,2))
9659             enddo
9660           enddo
9661         enddo
9662 ! AEAb1 and AEAb2
9663 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9664 ! They are needed only when the fifth- or the sixth-order cumulants are
9665 ! indluded.
9666         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9667         call transpose2(AEA(1,1,1),auxmat(1,1))
9668         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9669         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9670         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9671         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9672         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9673         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9674         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9675         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9676         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9677         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9678         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9679         call transpose2(AEA(1,1,2),auxmat(1,1))
9680         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
9681         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9682         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9683         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9684         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
9685         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9686         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
9687         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
9688         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9689         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9690         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9691 ! Calculate the Cartesian derivatives of the vectors.
9692         do iii=1,2
9693           do kkk=1,5
9694             do lll=1,3
9695               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9696               call matvec2(auxmat(1,1),b1(1,iti),&
9697                 AEAb1derx(1,lll,kkk,iii,1,1))
9698               call matvec2(auxmat(1,1),Ub2(1,i),&
9699                 AEAb2derx(1,lll,kkk,iii,1,1))
9700               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9701                 AEAb1derx(1,lll,kkk,iii,2,1))
9702               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9703                 AEAb2derx(1,lll,kkk,iii,2,1))
9704               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9705               call matvec2(auxmat(1,1),b1(1,itj),&
9706                 AEAb1derx(1,lll,kkk,iii,1,2))
9707               call matvec2(auxmat(1,1),Ub2(1,j),&
9708                 AEAb2derx(1,lll,kkk,iii,1,2))
9709               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9710                 AEAb1derx(1,lll,kkk,iii,2,2))
9711               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
9712                 AEAb2derx(1,lll,kkk,iii,2,2))
9713             enddo
9714           enddo
9715         enddo
9716         ENDIF
9717 ! End vectors
9718       else
9719 ! Antiparallel orientation of the two CA-CA-CA frames.
9720         if (i.gt.1) then
9721           iti=itortyp(itype(i,1))
9722         else
9723           iti=ntortyp+1
9724         endif
9725         itk1=itortyp(itype(k+1,1))
9726         itl=itortyp(itype(l,1))
9727         itj=itortyp(itype(j,1))
9728         if (j.lt.nres-1) then
9729           itj1=itortyp(itype(j+1,1))
9730         else
9731           itj1=ntortyp+1
9732         endif
9733 ! A2 kernel(j-1)T A1T
9734         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9735          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
9736          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9737 ! Following matrices are needed only for 6-th order cumulants
9738         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9739            j.eq.i+4 .and. l.eq.i+3)) THEN
9740         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9741          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
9742          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9743         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9744          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
9745          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9746          ADtEAderx(1,1,1,1,1,1))
9747         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9748          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
9749          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9750          ADtEA1derx(1,1,1,1,1,1))
9751         ENDIF
9752 ! End 6-th order cumulants
9753         call transpose2(EUgder(1,1,k),auxmat(1,1))
9754         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9755         call transpose2(EUg(1,1,k),auxmat(1,1))
9756         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9757         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9758         do iii=1,2
9759           do kkk=1,5
9760             do lll=1,3
9761               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9762                 EAEAderx(1,1,lll,kkk,iii,1))
9763             enddo
9764           enddo
9765         enddo
9766 ! A2T kernel(i+1)T A1
9767         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9768          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
9769          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9770 ! Following matrices are needed only for 6-th order cumulants
9771         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9772            j.eq.i+4 .and. l.eq.i+3)) THEN
9773         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9774          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
9775          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9776         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9777          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
9778          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9779          ADtEAderx(1,1,1,1,1,2))
9780         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9781          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
9782          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9783          ADtEA1derx(1,1,1,1,1,2))
9784         ENDIF
9785 ! End 6-th order cumulants
9786         call transpose2(EUgder(1,1,j),auxmat(1,1))
9787         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9788         call transpose2(EUg(1,1,j),auxmat(1,1))
9789         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9790         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9791         do iii=1,2
9792           do kkk=1,5
9793             do lll=1,3
9794               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9795                 EAEAderx(1,1,lll,kkk,iii,2))
9796             enddo
9797           enddo
9798         enddo
9799 ! AEAb1 and AEAb2
9800 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9801 ! They are needed only when the fifth- or the sixth-order cumulants are
9802 ! indluded.
9803         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
9804           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9805         call transpose2(AEA(1,1,1),auxmat(1,1))
9806         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9807         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9808         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9809         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9810         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9811         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9812         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9813         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9814         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9815         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9816         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9817         call transpose2(AEA(1,1,2),auxmat(1,1))
9818         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
9819         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9820         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9821         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9822         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
9823         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9824         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
9825         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
9826         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9827         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9828         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9829 ! Calculate the Cartesian derivatives of the vectors.
9830         do iii=1,2
9831           do kkk=1,5
9832             do lll=1,3
9833               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9834               call matvec2(auxmat(1,1),b1(1,iti),&
9835                 AEAb1derx(1,lll,kkk,iii,1,1))
9836               call matvec2(auxmat(1,1),Ub2(1,i),&
9837                 AEAb2derx(1,lll,kkk,iii,1,1))
9838               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9839                 AEAb1derx(1,lll,kkk,iii,2,1))
9840               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9841                 AEAb2derx(1,lll,kkk,iii,2,1))
9842               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9843               call matvec2(auxmat(1,1),b1(1,itl),&
9844                 AEAb1derx(1,lll,kkk,iii,1,2))
9845               call matvec2(auxmat(1,1),Ub2(1,l),&
9846                 AEAb2derx(1,lll,kkk,iii,1,2))
9847               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
9848                 AEAb1derx(1,lll,kkk,iii,2,2))
9849               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
9850                 AEAb2derx(1,lll,kkk,iii,2,2))
9851             enddo
9852           enddo
9853         enddo
9854         ENDIF
9855 ! End vectors
9856       endif
9857       return
9858       end subroutine calc_eello
9859 !-----------------------------------------------------------------------------
9860       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
9861       use comm_kut
9862       implicit none
9863       integer :: nderg
9864       logical :: transp
9865       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
9866       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
9867       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
9868       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
9869       integer :: iii,kkk,lll
9870       integer :: jjj,mmm
9871 !el      logical :: lprn
9872 !el      common /kutas/ lprn
9873       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9874       do iii=1,nderg
9875         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
9876           AKAderg(1,1,iii))
9877       enddo
9878 !d      if (lprn) write (2,*) 'In kernel'
9879       do kkk=1,5
9880 !d        if (lprn) write (2,*) 'kkk=',kkk
9881         do lll=1,3
9882           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
9883             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9884 !d          if (lprn) then
9885 !d            write (2,*) 'lll=',lll
9886 !d            write (2,*) 'iii=1'
9887 !d            do jjj=1,2
9888 !d              write (2,'(3(2f10.5),5x)')
9889 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9890 !d            enddo
9891 !d          endif
9892           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
9893             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9894 !d          if (lprn) then
9895 !d            write (2,*) 'lll=',lll
9896 !d            write (2,*) 'iii=2'
9897 !d            do jjj=1,2
9898 !d              write (2,'(3(2f10.5),5x)')
9899 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9900 !d            enddo
9901 !d          endif
9902         enddo
9903       enddo
9904       return
9905       end subroutine kernel
9906 !-----------------------------------------------------------------------------
9907       real(kind=8) function eello4(i,j,k,l,jj,kk)
9908 !      implicit real*8 (a-h,o-z)
9909 !      include 'DIMENSIONS'
9910 !      include 'COMMON.IOUNITS'
9911 !      include 'COMMON.CHAIN'
9912 !      include 'COMMON.DERIV'
9913 !      include 'COMMON.INTERACT'
9914 !      include 'COMMON.CONTACTS'
9915 !      include 'COMMON.TORSION'
9916 !      include 'COMMON.VAR'
9917 !      include 'COMMON.GEO'
9918       real(kind=8),dimension(2,2) :: pizda
9919       real(kind=8),dimension(3) :: ggg1,ggg2
9920       real(kind=8) ::  eel4,glongij,glongkl
9921       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9922 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9923 !d        eello4=0.0d0
9924 !d        return
9925 !d      endif
9926 !d      print *,'eello4:',i,j,k,l,jj,kk
9927 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
9928 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
9929 !old      eij=facont_hb(jj,i)
9930 !old      ekl=facont_hb(kk,k)
9931 !old      ekont=eij*ekl
9932       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9933 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9934       gcorr_loc(k-1)=gcorr_loc(k-1) &
9935          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9936       if (l.eq.j+1) then
9937         gcorr_loc(l-1)=gcorr_loc(l-1) &
9938            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9939       else
9940         gcorr_loc(j-1)=gcorr_loc(j-1) &
9941            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9942       endif
9943       do iii=1,2
9944         do kkk=1,5
9945           do lll=1,3
9946             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
9947                               -EAEAderx(2,2,lll,kkk,iii,1)
9948 !d            derx(lll,kkk,iii)=0.0d0
9949           enddo
9950         enddo
9951       enddo
9952 !d      gcorr_loc(l-1)=0.0d0
9953 !d      gcorr_loc(j-1)=0.0d0
9954 !d      gcorr_loc(k-1)=0.0d0
9955 !d      eel4=1.0d0
9956 !d      write (iout,*)'Contacts have occurred for peptide groups',
9957 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9958 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9959       if (j.lt.nres-1) then
9960         j1=j+1
9961         j2=j-1
9962       else
9963         j1=j-1
9964         j2=j-2
9965       endif
9966       if (l.lt.nres-1) then
9967         l1=l+1
9968         l2=l-1
9969       else
9970         l1=l-1
9971         l2=l-2
9972       endif
9973       do ll=1,3
9974 !grad        ggg1(ll)=eel4*g_contij(ll,1)
9975 !grad        ggg2(ll)=eel4*g_contij(ll,2)
9976         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9977         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9978 !grad        ghalf=0.5d0*ggg1(ll)
9979         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9980         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9981         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9982         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9983         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9984         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9985 !grad        ghalf=0.5d0*ggg2(ll)
9986         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9987         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9988         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9989         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9990         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9991         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9992       enddo
9993 !grad      do m=i+1,j-1
9994 !grad        do ll=1,3
9995 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9996 !grad        enddo
9997 !grad      enddo
9998 !grad      do m=k+1,l-1
9999 !grad        do ll=1,3
10000 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10001 !grad        enddo
10002 !grad      enddo
10003 !grad      do m=i+2,j2
10004 !grad        do ll=1,3
10005 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10006 !grad        enddo
10007 !grad      enddo
10008 !grad      do m=k+2,l2
10009 !grad        do ll=1,3
10010 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10011 !grad        enddo
10012 !grad      enddo
10013 !d      do iii=1,nres-3
10014 !d        write (2,*) iii,gcorr_loc(iii)
10015 !d      enddo
10016       eello4=ekont*eel4
10017 !d      write (2,*) 'ekont',ekont
10018 !d      write (iout,*) 'eello4',ekont*eel4
10019       return
10020       end function eello4
10021 !-----------------------------------------------------------------------------
10022       real(kind=8) function eello5(i,j,k,l,jj,kk)
10023 !      implicit real*8 (a-h,o-z)
10024 !      include 'DIMENSIONS'
10025 !      include 'COMMON.IOUNITS'
10026 !      include 'COMMON.CHAIN'
10027 !      include 'COMMON.DERIV'
10028 !      include 'COMMON.INTERACT'
10029 !      include 'COMMON.CONTACTS'
10030 !      include 'COMMON.TORSION'
10031 !      include 'COMMON.VAR'
10032 !      include 'COMMON.GEO'
10033       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10034       real(kind=8),dimension(2) :: vv
10035       real(kind=8),dimension(3) :: ggg1,ggg2
10036       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
10037       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
10038       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
10039 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10040 !                                                                              C
10041 !                            Parallel chains                                   C
10042 !                                                                              C
10043 !          o             o                   o             o                   C
10044 !         /l\           / \             \   / \           / \   /              C
10045 !        /   \         /   \             \ /   \         /   \ /               C
10046 !       j| o |l1       | o |                o| o |         | o |o                C
10047 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10048 !      \i/   \         /   \ /             /   \         /   \                 C
10049 !       o    k1             o                                                  C
10050 !         (I)          (II)                (III)          (IV)                 C
10051 !                                                                              C
10052 !      eello5_1        eello5_2            eello5_3       eello5_4             C
10053 !                                                                              C
10054 !                            Antiparallel chains                               C
10055 !                                                                              C
10056 !          o             o                   o             o                   C
10057 !         /j\           / \             \   / \           / \   /              C
10058 !        /   \         /   \             \ /   \         /   \ /               C
10059 !      j1| o |l        | o |                o| o |         | o |o                C
10060 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10061 !      \i/   \         /   \ /             /   \         /   \                 C
10062 !       o     k1            o                                                  C
10063 !         (I)          (II)                (III)          (IV)                 C
10064 !                                                                              C
10065 !      eello5_1        eello5_2            eello5_3       eello5_4             C
10066 !                                                                              C
10067 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
10068 !                                                                              C
10069 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10070 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10071 !d        eello5=0.0d0
10072 !d        return
10073 !d      endif
10074 !d      write (iout,*)
10075 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10076 !d     &   ' and',k,l
10077       itk=itortyp(itype(k,1))
10078       itl=itortyp(itype(l,1))
10079       itj=itortyp(itype(j,1))
10080       eello5_1=0.0d0
10081       eello5_2=0.0d0
10082       eello5_3=0.0d0
10083       eello5_4=0.0d0
10084 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10085 !d     &   eel5_3_num,eel5_4_num)
10086       do iii=1,2
10087         do kkk=1,5
10088           do lll=1,3
10089             derx(lll,kkk,iii)=0.0d0
10090           enddo
10091         enddo
10092       enddo
10093 !d      eij=facont_hb(jj,i)
10094 !d      ekl=facont_hb(kk,k)
10095 !d      ekont=eij*ekl
10096 !d      write (iout,*)'Contacts have occurred for peptide groups',
10097 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
10098 !d      goto 1111
10099 ! Contribution from the graph I.
10100 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10101 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10102       call transpose2(EUg(1,1,k),auxmat(1,1))
10103       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10104       vv(1)=pizda(1,1)-pizda(2,2)
10105       vv(2)=pizda(1,2)+pizda(2,1)
10106       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
10107        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10108 ! Explicit gradient in virtual-dihedral angles.
10109       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
10110        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
10111        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10112       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10113       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10114       vv(1)=pizda(1,1)-pizda(2,2)
10115       vv(2)=pizda(1,2)+pizda(2,1)
10116       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10117        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
10118        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10119       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10120       vv(1)=pizda(1,1)-pizda(2,2)
10121       vv(2)=pizda(1,2)+pizda(2,1)
10122       if (l.eq.j+1) then
10123         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
10124          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
10125          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10126       else
10127         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
10128          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
10129          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10130       endif
10131 ! Cartesian gradient
10132       do iii=1,2
10133         do kkk=1,5
10134           do lll=1,3
10135             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
10136               pizda(1,1))
10137             vv(1)=pizda(1,1)-pizda(2,2)
10138             vv(2)=pizda(1,2)+pizda(2,1)
10139             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
10140              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
10141              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10142           enddo
10143         enddo
10144       enddo
10145 !      goto 1112
10146 !1111  continue
10147 ! Contribution from graph II
10148       call transpose2(EE(1,1,itk),auxmat(1,1))
10149       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10150       vv(1)=pizda(1,1)+pizda(2,2)
10151       vv(2)=pizda(2,1)-pizda(1,2)
10152       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
10153        -0.5d0*scalar2(vv(1),Ctobr(1,k))
10154 ! Explicit gradient in virtual-dihedral angles.
10155       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10156        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10157       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10158       vv(1)=pizda(1,1)+pizda(2,2)
10159       vv(2)=pizda(2,1)-pizda(1,2)
10160       if (l.eq.j+1) then
10161         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
10162          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
10163          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10164       else
10165         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
10166          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
10167          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10168       endif
10169 ! Cartesian gradient
10170       do iii=1,2
10171         do kkk=1,5
10172           do lll=1,3
10173             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
10174               pizda(1,1))
10175             vv(1)=pizda(1,1)+pizda(2,2)
10176             vv(2)=pizda(2,1)-pizda(1,2)
10177             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
10178              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
10179              -0.5d0*scalar2(vv(1),Ctobr(1,k))
10180           enddo
10181         enddo
10182       enddo
10183 !d      goto 1112
10184 !d1111  continue
10185       if (l.eq.j+1) then
10186 !d        goto 1110
10187 ! Parallel orientation
10188 ! Contribution from graph III
10189         call transpose2(EUg(1,1,l),auxmat(1,1))
10190         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10191         vv(1)=pizda(1,1)-pizda(2,2)
10192         vv(2)=pizda(1,2)+pizda(2,1)
10193         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
10194          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10195 ! Explicit gradient in virtual-dihedral angles.
10196         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
10197          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
10198          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10199         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10200         vv(1)=pizda(1,1)-pizda(2,2)
10201         vv(2)=pizda(1,2)+pizda(2,1)
10202         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10203          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
10204          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10205         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10206         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10207         vv(1)=pizda(1,1)-pizda(2,2)
10208         vv(2)=pizda(1,2)+pizda(2,1)
10209         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
10210          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
10211          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10212 ! Cartesian gradient
10213         do iii=1,2
10214           do kkk=1,5
10215             do lll=1,3
10216               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
10217                 pizda(1,1))
10218               vv(1)=pizda(1,1)-pizda(2,2)
10219               vv(2)=pizda(1,2)+pizda(2,1)
10220               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
10221                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
10222                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10223             enddo
10224           enddo
10225         enddo
10226 !d        goto 1112
10227 ! Contribution from graph IV
10228 !d1110    continue
10229         call transpose2(EE(1,1,itl),auxmat(1,1))
10230         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10231         vv(1)=pizda(1,1)+pizda(2,2)
10232         vv(2)=pizda(2,1)-pizda(1,2)
10233         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
10234          -0.5d0*scalar2(vv(1),Ctobr(1,l))
10235 ! Explicit gradient in virtual-dihedral angles.
10236         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
10237          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10238         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10239         vv(1)=pizda(1,1)+pizda(2,2)
10240         vv(2)=pizda(2,1)-pizda(1,2)
10241         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10242          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
10243          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10244 ! Cartesian gradient
10245         do iii=1,2
10246           do kkk=1,5
10247             do lll=1,3
10248               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
10249                 pizda(1,1))
10250               vv(1)=pizda(1,1)+pizda(2,2)
10251               vv(2)=pizda(2,1)-pizda(1,2)
10252               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
10253                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
10254                -0.5d0*scalar2(vv(1),Ctobr(1,l))
10255             enddo
10256           enddo
10257         enddo
10258       else
10259 ! Antiparallel orientation
10260 ! Contribution from graph III
10261 !        goto 1110
10262         call transpose2(EUg(1,1,j),auxmat(1,1))
10263         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10264         vv(1)=pizda(1,1)-pizda(2,2)
10265         vv(2)=pizda(1,2)+pizda(2,1)
10266         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
10267          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10268 ! Explicit gradient in virtual-dihedral angles.
10269         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
10270          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
10271          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10272         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10273         vv(1)=pizda(1,1)-pizda(2,2)
10274         vv(2)=pizda(1,2)+pizda(2,1)
10275         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10276          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
10277          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10278         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10279         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10280         vv(1)=pizda(1,1)-pizda(2,2)
10281         vv(2)=pizda(1,2)+pizda(2,1)
10282         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
10283          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
10284          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10285 ! Cartesian gradient
10286         do iii=1,2
10287           do kkk=1,5
10288             do lll=1,3
10289               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
10290                 pizda(1,1))
10291               vv(1)=pizda(1,1)-pizda(2,2)
10292               vv(2)=pizda(1,2)+pizda(2,1)
10293               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
10294                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
10295                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10296             enddo
10297           enddo
10298         enddo
10299 !d        goto 1112
10300 ! Contribution from graph IV
10301 1110    continue
10302         call transpose2(EE(1,1,itj),auxmat(1,1))
10303         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10304         vv(1)=pizda(1,1)+pizda(2,2)
10305         vv(2)=pizda(2,1)-pizda(1,2)
10306         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
10307          -0.5d0*scalar2(vv(1),Ctobr(1,j))
10308 ! Explicit gradient in virtual-dihedral angles.
10309         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
10310          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10311         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10312         vv(1)=pizda(1,1)+pizda(2,2)
10313         vv(2)=pizda(2,1)-pizda(1,2)
10314         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10315          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
10316          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10317 ! Cartesian gradient
10318         do iii=1,2
10319           do kkk=1,5
10320             do lll=1,3
10321               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
10322                 pizda(1,1))
10323               vv(1)=pizda(1,1)+pizda(2,2)
10324               vv(2)=pizda(2,1)-pizda(1,2)
10325               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
10326                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
10327                -0.5d0*scalar2(vv(1),Ctobr(1,j))
10328             enddo
10329           enddo
10330         enddo
10331       endif
10332 1112  continue
10333       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10334 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10335 !d        write (2,*) 'ijkl',i,j,k,l
10336 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10337 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10338 !d      endif
10339 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10340 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10341 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10342 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10343       if (j.lt.nres-1) then
10344         j1=j+1
10345         j2=j-1
10346       else
10347         j1=j-1
10348         j2=j-2
10349       endif
10350       if (l.lt.nres-1) then
10351         l1=l+1
10352         l2=l-1
10353       else
10354         l1=l-1
10355         l2=l-2
10356       endif
10357 !d      eij=1.0d0
10358 !d      ekl=1.0d0
10359 !d      ekont=1.0d0
10360 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10361 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
10362 !        summed up outside the subrouine as for the other subroutines
10363 !        handling long-range interactions. The old code is commented out
10364 !        with "cgrad" to keep track of changes.
10365       do ll=1,3
10366 !grad        ggg1(ll)=eel5*g_contij(ll,1)
10367 !grad        ggg2(ll)=eel5*g_contij(ll,2)
10368         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10369         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10370 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10371 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10372 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10373 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10374 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10375 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10376 !     &   gradcorr5ij,
10377 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10378 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10379 !grad        ghalf=0.5d0*ggg1(ll)
10380 !d        ghalf=0.0d0
10381         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10382         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10383         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10384         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10385         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10386         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10387 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10388 !grad        ghalf=0.5d0*ggg2(ll)
10389         ghalf=0.0d0
10390         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
10391         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10392         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
10393         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10394         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10395         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10396       enddo
10397 !d      goto 1112
10398 !grad      do m=i+1,j-1
10399 !grad        do ll=1,3
10400 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10401 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10402 !grad        enddo
10403 !grad      enddo
10404 !grad      do m=k+1,l-1
10405 !grad        do ll=1,3
10406 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10407 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10408 !grad        enddo
10409 !grad      enddo
10410 !1112  continue
10411 !grad      do m=i+2,j2
10412 !grad        do ll=1,3
10413 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10414 !grad        enddo
10415 !grad      enddo
10416 !grad      do m=k+2,l2
10417 !grad        do ll=1,3
10418 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10419 !grad        enddo
10420 !grad      enddo
10421 !d      do iii=1,nres-3
10422 !d        write (2,*) iii,g_corr5_loc(iii)
10423 !d      enddo
10424       eello5=ekont*eel5
10425 !d      write (2,*) 'ekont',ekont
10426 !d      write (iout,*) 'eello5',ekont*eel5
10427       return
10428       end function eello5
10429 !-----------------------------------------------------------------------------
10430       real(kind=8) function eello6(i,j,k,l,jj,kk)
10431 !      implicit real*8 (a-h,o-z)
10432 !      include 'DIMENSIONS'
10433 !      include 'COMMON.IOUNITS'
10434 !      include 'COMMON.CHAIN'
10435 !      include 'COMMON.DERIV'
10436 !      include 'COMMON.INTERACT'
10437 !      include 'COMMON.CONTACTS'
10438 !      include 'COMMON.TORSION'
10439 !      include 'COMMON.VAR'
10440 !      include 'COMMON.GEO'
10441 !      include 'COMMON.FFIELD'
10442       real(kind=8),dimension(3) :: ggg1,ggg2
10443       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
10444                    eello6_6,eel6
10445       real(kind=8) :: gradcorr6ij,gradcorr6kl
10446       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
10447 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10448 !d        eello6=0.0d0
10449 !d        return
10450 !d      endif
10451 !d      write (iout,*)
10452 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10453 !d     &   ' and',k,l
10454       eello6_1=0.0d0
10455       eello6_2=0.0d0
10456       eello6_3=0.0d0
10457       eello6_4=0.0d0
10458       eello6_5=0.0d0
10459       eello6_6=0.0d0
10460 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10461 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10462       do iii=1,2
10463         do kkk=1,5
10464           do lll=1,3
10465             derx(lll,kkk,iii)=0.0d0
10466           enddo
10467         enddo
10468       enddo
10469 !d      eij=facont_hb(jj,i)
10470 !d      ekl=facont_hb(kk,k)
10471 !d      ekont=eij*ekl
10472 !d      eij=1.0d0
10473 !d      ekl=1.0d0
10474 !d      ekont=1.0d0
10475       if (l.eq.j+1) then
10476         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10477         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10478         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10479         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10480         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10481         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10482       else
10483         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10484         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10485         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10486         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10487         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10488           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10489         else
10490           eello6_5=0.0d0
10491         endif
10492         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10493       endif
10494 ! If turn contributions are considered, they will be handled separately.
10495       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10496 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10497 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10498 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10499 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10500 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10501 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10502 !d      goto 1112
10503       if (j.lt.nres-1) then
10504         j1=j+1
10505         j2=j-1
10506       else
10507         j1=j-1
10508         j2=j-2
10509       endif
10510       if (l.lt.nres-1) then
10511         l1=l+1
10512         l2=l-1
10513       else
10514         l1=l-1
10515         l2=l-2
10516       endif
10517       do ll=1,3
10518 !grad        ggg1(ll)=eel6*g_contij(ll,1)
10519 !grad        ggg2(ll)=eel6*g_contij(ll,2)
10520 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10521 !grad        ghalf=0.5d0*ggg1(ll)
10522 !d        ghalf=0.0d0
10523         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10524         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10525         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10526         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10527         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10528         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10529         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10530         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10531 !grad        ghalf=0.5d0*ggg2(ll)
10532 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10533 !d        ghalf=0.0d0
10534         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10535         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10536         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10537         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10538         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10539         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10540       enddo
10541 !d      goto 1112
10542 !grad      do m=i+1,j-1
10543 !grad        do ll=1,3
10544 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10545 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10546 !grad        enddo
10547 !grad      enddo
10548 !grad      do m=k+1,l-1
10549 !grad        do ll=1,3
10550 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10551 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10552 !grad        enddo
10553 !grad      enddo
10554 !grad1112  continue
10555 !grad      do m=i+2,j2
10556 !grad        do ll=1,3
10557 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10558 !grad        enddo
10559 !grad      enddo
10560 !grad      do m=k+2,l2
10561 !grad        do ll=1,3
10562 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10563 !grad        enddo
10564 !grad      enddo
10565 !d      do iii=1,nres-3
10566 !d        write (2,*) iii,g_corr6_loc(iii)
10567 !d      enddo
10568       eello6=ekont*eel6
10569 !d      write (2,*) 'ekont',ekont
10570 !d      write (iout,*) 'eello6',ekont*eel6
10571       return
10572       end function eello6
10573 !-----------------------------------------------------------------------------
10574       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
10575       use comm_kut
10576 !      implicit real*8 (a-h,o-z)
10577 !      include 'DIMENSIONS'
10578 !      include 'COMMON.IOUNITS'
10579 !      include 'COMMON.CHAIN'
10580 !      include 'COMMON.DERIV'
10581 !      include 'COMMON.INTERACT'
10582 !      include 'COMMON.CONTACTS'
10583 !      include 'COMMON.TORSION'
10584 !      include 'COMMON.VAR'
10585 !      include 'COMMON.GEO'
10586       real(kind=8),dimension(2) :: vv,vv1
10587       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
10588       logical :: swap
10589 !el      logical :: lprn
10590 !el      common /kutas/ lprn
10591       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
10592       real(kind=8) :: s1,s2,s3,s4,s5
10593 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10594 !                                                                              C
10595 !      Parallel       Antiparallel                                             C
10596 !                                                                              C
10597 !          o             o                                                     C
10598 !         /l\           /j\                                                    C
10599 !        /   \         /   \                                                   C
10600 !       /| o |         | o |\                                                  C
10601 !     \ j|/k\|  /   \  |/k\|l /                                                C
10602 !      \ /   \ /     \ /   \ /                                                 C
10603 !       o     o       o     o                                                  C
10604 !       i             i                                                        C
10605 !                                                                              C
10606 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10607       itk=itortyp(itype(k,1))
10608       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10609       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10610       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10611       call transpose2(EUgC(1,1,k),auxmat(1,1))
10612       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10613       vv1(1)=pizda1(1,1)-pizda1(2,2)
10614       vv1(2)=pizda1(1,2)+pizda1(2,1)
10615       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10616       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
10617       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
10618       s5=scalar2(vv(1),Dtobr2(1,i))
10619 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10620       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10621       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
10622        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
10623        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
10624        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
10625        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
10626        +scalar2(vv(1),Dtobr2der(1,i)))
10627       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10628       vv1(1)=pizda1(1,1)-pizda1(2,2)
10629       vv1(2)=pizda1(1,2)+pizda1(2,1)
10630       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
10631       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
10632       if (l.eq.j+1) then
10633         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
10634        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10635        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10636        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10637        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10638       else
10639         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
10640        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10641        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10642        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10643        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10644       endif
10645       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10646       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10647       vv1(1)=pizda1(1,1)-pizda1(2,2)
10648       vv1(2)=pizda1(1,2)+pizda1(2,1)
10649       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
10650        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
10651        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
10652        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10653       do iii=1,2
10654         if (swap) then
10655           ind=3-iii
10656         else
10657           ind=iii
10658         endif
10659         do kkk=1,5
10660           do lll=1,3
10661             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10662             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10663             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10664             call transpose2(EUgC(1,1,k),auxmat(1,1))
10665             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10666               pizda1(1,1))
10667             vv1(1)=pizda1(1,1)-pizda1(2,2)
10668             vv1(2)=pizda1(1,2)+pizda1(2,1)
10669             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10670             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
10671              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
10672             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
10673              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
10674             s5=scalar2(vv(1),Dtobr2(1,i))
10675             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10676           enddo
10677         enddo
10678       enddo
10679       return
10680       end function eello6_graph1
10681 !-----------------------------------------------------------------------------
10682       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
10683       use comm_kut
10684 !      implicit real*8 (a-h,o-z)
10685 !      include 'DIMENSIONS'
10686 !      include 'COMMON.IOUNITS'
10687 !      include 'COMMON.CHAIN'
10688 !      include 'COMMON.DERIV'
10689 !      include 'COMMON.INTERACT'
10690 !      include 'COMMON.CONTACTS'
10691 !      include 'COMMON.TORSION'
10692 !      include 'COMMON.VAR'
10693 !      include 'COMMON.GEO'
10694       logical :: swap
10695       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
10696       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10697 !el      logical :: lprn
10698 !el      common /kutas/ lprn
10699       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
10700       real(kind=8) :: s2,s3,s4
10701 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10702 !                                                                              C
10703 !      Parallel       Antiparallel                                             C
10704 !                                                                              C
10705 !          o             o                                                     C
10706 !     \   /l\           /j\   /                                                C
10707 !      \ /   \         /   \ /                                                 C
10708 !       o| o |         | o |o                                                  C
10709 !     \ j|/k\|      \  |/k\|l                                                  C
10710 !      \ /   \       \ /   \                                                   C
10711 !       o             o                                                        C
10712 !       i             i                                                        C
10713 !                                                                              C
10714 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10715 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10716 ! AL 7/4/01 s1 would occur in the sixth-order moment,
10717 !           but not in a cluster cumulant
10718 #ifdef MOMENT
10719       s1=dip(1,jj,i)*dip(1,kk,k)
10720 #endif
10721       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10722       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10723       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10724       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10725       call transpose2(EUg(1,1,k),auxmat(1,1))
10726       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10727       vv(1)=pizda(1,1)-pizda(2,2)
10728       vv(2)=pizda(1,2)+pizda(2,1)
10729       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10730 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10731 #ifdef MOMENT
10732       eello6_graph2=-(s1+s2+s3+s4)
10733 #else
10734       eello6_graph2=-(s2+s3+s4)
10735 #endif
10736 !      eello6_graph2=-s3
10737 ! Derivatives in gamma(i-1)
10738       if (i.gt.1) then
10739 #ifdef MOMENT
10740         s1=dipderg(1,jj,i)*dip(1,kk,k)
10741 #endif
10742         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10743         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10744         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10745         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10746 #ifdef MOMENT
10747         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10748 #else
10749         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10750 #endif
10751 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10752       endif
10753 ! Derivatives in gamma(k-1)
10754 #ifdef MOMENT
10755       s1=dip(1,jj,i)*dipderg(1,kk,k)
10756 #endif
10757       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10758       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10759       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10760       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10761       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10762       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10763       vv(1)=pizda(1,1)-pizda(2,2)
10764       vv(2)=pizda(1,2)+pizda(2,1)
10765       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10766 #ifdef MOMENT
10767       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10768 #else
10769       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10770 #endif
10771 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10772 ! Derivatives in gamma(j-1) or gamma(l-1)
10773       if (j.gt.1) then
10774 #ifdef MOMENT
10775         s1=dipderg(3,jj,i)*dip(1,kk,k)
10776 #endif
10777         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10778         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10779         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10780         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10781         vv(1)=pizda(1,1)-pizda(2,2)
10782         vv(2)=pizda(1,2)+pizda(2,1)
10783         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10784 #ifdef MOMENT
10785         if (swap) then
10786           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10787         else
10788           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10789         endif
10790 #endif
10791         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10792 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10793       endif
10794 ! Derivatives in gamma(l-1) or gamma(j-1)
10795       if (l.gt.1) then
10796 #ifdef MOMENT
10797         s1=dip(1,jj,i)*dipderg(3,kk,k)
10798 #endif
10799         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10800         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10801         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10802         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10803         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10804         vv(1)=pizda(1,1)-pizda(2,2)
10805         vv(2)=pizda(1,2)+pizda(2,1)
10806         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10807 #ifdef MOMENT
10808         if (swap) then
10809           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10810         else
10811           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10812         endif
10813 #endif
10814         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10815 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10816       endif
10817 ! Cartesian derivatives.
10818       if (lprn) then
10819         write (2,*) 'In eello6_graph2'
10820         do iii=1,2
10821           write (2,*) 'iii=',iii
10822           do kkk=1,5
10823             write (2,*) 'kkk=',kkk
10824             do jjj=1,2
10825               write (2,'(3(2f10.5),5x)') &
10826               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10827             enddo
10828           enddo
10829         enddo
10830       endif
10831       do iii=1,2
10832         do kkk=1,5
10833           do lll=1,3
10834 #ifdef MOMENT
10835             if (iii.eq.1) then
10836               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10837             else
10838               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10839             endif
10840 #endif
10841             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
10842               auxvec(1))
10843             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10844             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
10845               auxvec(1))
10846             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10847             call transpose2(EUg(1,1,k),auxmat(1,1))
10848             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
10849               pizda(1,1))
10850             vv(1)=pizda(1,1)-pizda(2,2)
10851             vv(2)=pizda(1,2)+pizda(2,1)
10852             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10853 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10854 #ifdef MOMENT
10855             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10856 #else
10857             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10858 #endif
10859             if (swap) then
10860               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10861             else
10862               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10863             endif
10864           enddo
10865         enddo
10866       enddo
10867       return
10868       end function eello6_graph2
10869 !-----------------------------------------------------------------------------
10870       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
10871 !      implicit real*8 (a-h,o-z)
10872 !      include 'DIMENSIONS'
10873 !      include 'COMMON.IOUNITS'
10874 !      include 'COMMON.CHAIN'
10875 !      include 'COMMON.DERIV'
10876 !      include 'COMMON.INTERACT'
10877 !      include 'COMMON.CONTACTS'
10878 !      include 'COMMON.TORSION'
10879 !      include 'COMMON.VAR'
10880 !      include 'COMMON.GEO'
10881       real(kind=8),dimension(2) :: vv,auxvec
10882       real(kind=8),dimension(2,2) :: pizda,auxmat
10883       logical :: swap
10884       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
10885       real(kind=8) :: s1,s2,s3,s4
10886 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10887 !                                                                              C
10888 !      Parallel       Antiparallel                                             C
10889 !                                                                              C
10890 !          o             o                                                     C
10891 !         /l\   /   \   /j\                                                    C
10892 !        /   \ /     \ /   \                                                   C
10893 !       /| o |o       o| o |\                                                  C
10894 !       j|/k\|  /      |/k\|l /                                                C
10895 !        /   \ /       /   \ /                                                 C
10896 !       /     o       /     o                                                  C
10897 !       i             i                                                        C
10898 !                                                                              C
10899 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10900 !
10901 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10902 !           energy moment and not to the cluster cumulant.
10903       iti=itortyp(itype(i,1))
10904       if (j.lt.nres-1) then
10905         itj1=itortyp(itype(j+1,1))
10906       else
10907         itj1=ntortyp+1
10908       endif
10909       itk=itortyp(itype(k,1))
10910       itk1=itortyp(itype(k+1,1))
10911       if (l.lt.nres-1) then
10912         itl1=itortyp(itype(l+1,1))
10913       else
10914         itl1=ntortyp+1
10915       endif
10916 #ifdef MOMENT
10917       s1=dip(4,jj,i)*dip(4,kk,k)
10918 #endif
10919       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
10920       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10921       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
10922       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10923       call transpose2(EE(1,1,itk),auxmat(1,1))
10924       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10925       vv(1)=pizda(1,1)+pizda(2,2)
10926       vv(2)=pizda(2,1)-pizda(1,2)
10927       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10928 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10929 !d     & "sum",-(s2+s3+s4)
10930 #ifdef MOMENT
10931       eello6_graph3=-(s1+s2+s3+s4)
10932 #else
10933       eello6_graph3=-(s2+s3+s4)
10934 #endif
10935 !      eello6_graph3=-s4
10936 ! Derivatives in gamma(k-1)
10937       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
10938       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10939       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10940       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10941 ! Derivatives in gamma(l-1)
10942       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
10943       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10944       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10945       vv(1)=pizda(1,1)+pizda(2,2)
10946       vv(2)=pizda(2,1)-pizda(1,2)
10947       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10948       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10949 ! Cartesian derivatives.
10950       do iii=1,2
10951         do kkk=1,5
10952           do lll=1,3
10953 #ifdef MOMENT
10954             if (iii.eq.1) then
10955               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10956             else
10957               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10958             endif
10959 #endif
10960             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
10961               auxvec(1))
10962             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10963             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
10964               auxvec(1))
10965             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10966             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
10967               pizda(1,1))
10968             vv(1)=pizda(1,1)+pizda(2,2)
10969             vv(2)=pizda(2,1)-pizda(1,2)
10970             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10971 #ifdef MOMENT
10972             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10973 #else
10974             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10975 #endif
10976             if (swap) then
10977               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10978             else
10979               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10980             endif
10981 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10982           enddo
10983         enddo
10984       enddo
10985       return
10986       end function eello6_graph3
10987 !-----------------------------------------------------------------------------
10988       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10989 !      implicit real*8 (a-h,o-z)
10990 !      include 'DIMENSIONS'
10991 !      include 'COMMON.IOUNITS'
10992 !      include 'COMMON.CHAIN'
10993 !      include 'COMMON.DERIV'
10994 !      include 'COMMON.INTERACT'
10995 !      include 'COMMON.CONTACTS'
10996 !      include 'COMMON.TORSION'
10997 !      include 'COMMON.VAR'
10998 !      include 'COMMON.GEO'
10999 !      include 'COMMON.FFIELD'
11000       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
11001       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
11002       logical :: swap
11003       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
11004               iii,kkk,lll
11005       real(kind=8) :: s1,s2,s3,s4
11006 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11007 !                                                                              C
11008 !      Parallel       Antiparallel                                             C
11009 !                                                                              C
11010 !          o             o                                                     C
11011 !         /l\   /   \   /j\                                                    C
11012 !        /   \ /     \ /   \                                                   C
11013 !       /| o |o       o| o |\                                                  C
11014 !     \ j|/k\|      \  |/k\|l                                                  C
11015 !      \ /   \       \ /   \                                                   C
11016 !       o     \       o     \                                                  C
11017 !       i             i                                                        C
11018 !                                                                              C
11019 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11020 !
11021 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
11022 !           energy moment and not to the cluster cumulant.
11023 !d      write (2,*) 'eello_graph4: wturn6',wturn6
11024       iti=itortyp(itype(i,1))
11025       itj=itortyp(itype(j,1))
11026       if (j.lt.nres-1) then
11027         itj1=itortyp(itype(j+1,1))
11028       else
11029         itj1=ntortyp+1
11030       endif
11031       itk=itortyp(itype(k,1))
11032       if (k.lt.nres-1) then
11033         itk1=itortyp(itype(k+1,1))
11034       else
11035         itk1=ntortyp+1
11036       endif
11037       itl=itortyp(itype(l,1))
11038       if (l.lt.nres-1) then
11039         itl1=itortyp(itype(l+1,1))
11040       else
11041         itl1=ntortyp+1
11042       endif
11043 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11044 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11045 !d     & ' itl',itl,' itl1',itl1
11046 #ifdef MOMENT
11047       if (imat.eq.1) then
11048         s1=dip(3,jj,i)*dip(3,kk,k)
11049       else
11050         s1=dip(2,jj,j)*dip(2,kk,l)
11051       endif
11052 #endif
11053       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11054       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11055       if (j.eq.l+1) then
11056         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
11057         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
11058       else
11059         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
11060         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
11061       endif
11062       call transpose2(EUg(1,1,k),auxmat(1,1))
11063       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11064       vv(1)=pizda(1,1)-pizda(2,2)
11065       vv(2)=pizda(2,1)+pizda(1,2)
11066       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11067 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11068 #ifdef MOMENT
11069       eello6_graph4=-(s1+s2+s3+s4)
11070 #else
11071       eello6_graph4=-(s2+s3+s4)
11072 #endif
11073 ! Derivatives in gamma(i-1)
11074       if (i.gt.1) then
11075 #ifdef MOMENT
11076         if (imat.eq.1) then
11077           s1=dipderg(2,jj,i)*dip(3,kk,k)
11078         else
11079           s1=dipderg(4,jj,j)*dip(2,kk,l)
11080         endif
11081 #endif
11082         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11083         if (j.eq.l+1) then
11084           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
11085           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
11086         else
11087           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
11088           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
11089         endif
11090         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11091         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11092 !d          write (2,*) 'turn6 derivatives'
11093 #ifdef MOMENT
11094           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11095 #else
11096           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11097 #endif
11098         else
11099 #ifdef MOMENT
11100           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11101 #else
11102           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11103 #endif
11104         endif
11105       endif
11106 ! Derivatives in gamma(k-1)
11107 #ifdef MOMENT
11108       if (imat.eq.1) then
11109         s1=dip(3,jj,i)*dipderg(2,kk,k)
11110       else
11111         s1=dip(2,jj,j)*dipderg(4,kk,l)
11112       endif
11113 #endif
11114       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11115       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11116       if (j.eq.l+1) then
11117         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
11118         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
11119       else
11120         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
11121         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
11122       endif
11123       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11124       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11125       vv(1)=pizda(1,1)-pizda(2,2)
11126       vv(2)=pizda(2,1)+pizda(1,2)
11127       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11128       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11129 #ifdef MOMENT
11130         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11131 #else
11132         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11133 #endif
11134       else
11135 #ifdef MOMENT
11136         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11137 #else
11138         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11139 #endif
11140       endif
11141 ! Derivatives in gamma(j-1) or gamma(l-1)
11142       if (l.eq.j+1 .and. l.gt.1) then
11143         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11144         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11145         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11146         vv(1)=pizda(1,1)-pizda(2,2)
11147         vv(2)=pizda(2,1)+pizda(1,2)
11148         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11149         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11150       else if (j.gt.1) then
11151         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11152         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11153         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11154         vv(1)=pizda(1,1)-pizda(2,2)
11155         vv(2)=pizda(2,1)+pizda(1,2)
11156         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11157         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11158           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11159         else
11160           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11161         endif
11162       endif
11163 ! Cartesian derivatives.
11164       do iii=1,2
11165         do kkk=1,5
11166           do lll=1,3
11167 #ifdef MOMENT
11168             if (iii.eq.1) then
11169               if (imat.eq.1) then
11170                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11171               else
11172                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11173               endif
11174             else
11175               if (imat.eq.1) then
11176                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11177               else
11178                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11179               endif
11180             endif
11181 #endif
11182             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
11183               auxvec(1))
11184             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11185             if (j.eq.l+1) then
11186               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
11187                 b1(1,itj1),auxvec(1))
11188               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
11189             else
11190               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
11191                 b1(1,itl1),auxvec(1))
11192               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
11193             endif
11194             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
11195               pizda(1,1))
11196             vv(1)=pizda(1,1)-pizda(2,2)
11197             vv(2)=pizda(2,1)+pizda(1,2)
11198             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11199             if (swap) then
11200               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11201 #ifdef MOMENT
11202                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
11203                    -(s1+s2+s4)
11204 #else
11205                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
11206                    -(s2+s4)
11207 #endif
11208                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11209               else
11210 #ifdef MOMENT
11211                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11212 #else
11213                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11214 #endif
11215                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11216               endif
11217             else
11218 #ifdef MOMENT
11219               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11220 #else
11221               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11222 #endif
11223               if (l.eq.j+1) then
11224                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11225               else
11226                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11227               endif
11228             endif
11229           enddo
11230         enddo
11231       enddo
11232       return
11233       end function eello6_graph4
11234 !-----------------------------------------------------------------------------
11235       real(kind=8) function eello_turn6(i,jj,kk)
11236 !      implicit real*8 (a-h,o-z)
11237 !      include 'DIMENSIONS'
11238 !      include 'COMMON.IOUNITS'
11239 !      include 'COMMON.CHAIN'
11240 !      include 'COMMON.DERIV'
11241 !      include 'COMMON.INTERACT'
11242 !      include 'COMMON.CONTACTS'
11243 !      include 'COMMON.TORSION'
11244 !      include 'COMMON.VAR'
11245 !      include 'COMMON.GEO'
11246       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
11247       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
11248       real(kind=8),dimension(3) :: ggg1,ggg2
11249       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
11250       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
11251 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11252 !           the respective energy moment and not to the cluster cumulant.
11253 !el local variables
11254       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
11255       integer :: j1,j2,l1,l2,ll
11256       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
11257       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
11258       s1=0.0d0
11259       s8=0.0d0
11260       s13=0.0d0
11261 !
11262       eello_turn6=0.0d0
11263       j=i+4
11264       k=i+1
11265       l=i+3
11266       iti=itortyp(itype(i,1))
11267       itk=itortyp(itype(k,1))
11268       itk1=itortyp(itype(k+1,1))
11269       itl=itortyp(itype(l,1))
11270       itj=itortyp(itype(j,1))
11271 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11272 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
11273 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11274 !d        eello6=0.0d0
11275 !d        return
11276 !d      endif
11277 !d      write (iout,*)
11278 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11279 !d     &   ' and',k,l
11280 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
11281       do iii=1,2
11282         do kkk=1,5
11283           do lll=1,3
11284             derx_turn(lll,kkk,iii)=0.0d0
11285           enddo
11286         enddo
11287       enddo
11288 !d      eij=1.0d0
11289 !d      ekl=1.0d0
11290 !d      ekont=1.0d0
11291       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11292 !d      eello6_5=0.0d0
11293 !d      write (2,*) 'eello6_5',eello6_5
11294 #ifdef MOMENT
11295       call transpose2(AEA(1,1,1),auxmat(1,1))
11296       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11297       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
11298       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11299 #endif
11300       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
11301       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11302       s2 = scalar2(b1(1,itk),vtemp1(1))
11303 #ifdef MOMENT
11304       call transpose2(AEA(1,1,2),atemp(1,1))
11305       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11306       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
11307       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11308 #endif
11309       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11310       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11311       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11312 #ifdef MOMENT
11313       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11314       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11315       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11316       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11317       ss13 = scalar2(b1(1,itk),vtemp4(1))
11318       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11319 #endif
11320 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11321 !      s1=0.0d0
11322 !      s2=0.0d0
11323 !      s8=0.0d0
11324 !      s12=0.0d0
11325 !      s13=0.0d0
11326       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11327 ! Derivatives in gamma(i+2)
11328       s1d =0.0d0
11329       s8d =0.0d0
11330 #ifdef MOMENT
11331       call transpose2(AEA(1,1,1),auxmatd(1,1))
11332       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11333       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11334       call transpose2(AEAderg(1,1,2),atempd(1,1))
11335       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11336       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11337 #endif
11338       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11339       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11340       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11341 !      s1d=0.0d0
11342 !      s2d=0.0d0
11343 !      s8d=0.0d0
11344 !      s12d=0.0d0
11345 !      s13d=0.0d0
11346       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11347 ! Derivatives in gamma(i+3)
11348 #ifdef MOMENT
11349       call transpose2(AEA(1,1,1),auxmatd(1,1))
11350       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11351       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
11352       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11353 #endif
11354       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
11355       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11356       s2d = scalar2(b1(1,itk),vtemp1d(1))
11357 #ifdef MOMENT
11358       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
11359       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
11360 #endif
11361       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11362 #ifdef MOMENT
11363       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11364       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11365       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11366 #endif
11367 !      s1d=0.0d0
11368 !      s2d=0.0d0
11369 !      s8d=0.0d0
11370 !      s12d=0.0d0
11371 !      s13d=0.0d0
11372 #ifdef MOMENT
11373       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
11374                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11375 #else
11376       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
11377                     -0.5d0*ekont*(s2d+s12d)
11378 #endif
11379 ! Derivatives in gamma(i+4)
11380       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11381       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11382       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11383 #ifdef MOMENT
11384       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11385       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11386       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11387 #endif
11388 !      s1d=0.0d0
11389 !      s2d=0.0d0
11390 !      s8d=0.0d0
11391 !      s12d=0.0d0
11392 !      s13d=0.0d0
11393 #ifdef MOMENT
11394       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11395 #else
11396       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11397 #endif
11398 ! Derivatives in gamma(i+5)
11399 #ifdef MOMENT
11400       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11401       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11402       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11403 #endif
11404       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
11405       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11406       s2d = scalar2(b1(1,itk),vtemp1d(1))
11407 #ifdef MOMENT
11408       call transpose2(AEA(1,1,2),atempd(1,1))
11409       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11410       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11411 #endif
11412       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11413       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11414 #ifdef MOMENT
11415       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11416       ss13d = scalar2(b1(1,itk),vtemp4d(1))
11417       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11418 #endif
11419 !      s1d=0.0d0
11420 !      s2d=0.0d0
11421 !      s8d=0.0d0
11422 !      s12d=0.0d0
11423 !      s13d=0.0d0
11424 #ifdef MOMENT
11425       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
11426                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11427 #else
11428       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
11429                     -0.5d0*ekont*(s2d+s12d)
11430 #endif
11431 ! Cartesian derivatives
11432       do iii=1,2
11433         do kkk=1,5
11434           do lll=1,3
11435 #ifdef MOMENT
11436             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11437             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11438             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11439 #endif
11440             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
11441             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
11442                 vtemp1d(1))
11443             s2d = scalar2(b1(1,itk),vtemp1d(1))
11444 #ifdef MOMENT
11445             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11446             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11447             s8d = -(atempd(1,1)+atempd(2,2))* &
11448                  scalar2(cc(1,1,itl),vtemp2(1))
11449 #endif
11450             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
11451                  auxmatd(1,1))
11452             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11453             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11454 !      s1d=0.0d0
11455 !      s2d=0.0d0
11456 !      s8d=0.0d0
11457 !      s12d=0.0d0
11458 !      s13d=0.0d0
11459 #ifdef MOMENT
11460             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
11461               - 0.5d0*(s1d+s2d)
11462 #else
11463             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
11464               - 0.5d0*s2d
11465 #endif
11466 #ifdef MOMENT
11467             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
11468               - 0.5d0*(s8d+s12d)
11469 #else
11470             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
11471               - 0.5d0*s12d
11472 #endif
11473           enddo
11474         enddo
11475       enddo
11476 #ifdef MOMENT
11477       do kkk=1,5
11478         do lll=1,3
11479           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
11480             achuj_tempd(1,1))
11481           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11482           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11483           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11484           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11485           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
11486             vtemp4d(1))
11487           ss13d = scalar2(b1(1,itk),vtemp4d(1))
11488           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11489           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11490         enddo
11491       enddo
11492 #endif
11493 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11494 !d     &  16*eel_turn6_num
11495 !d      goto 1112
11496       if (j.lt.nres-1) then
11497         j1=j+1
11498         j2=j-1
11499       else
11500         j1=j-1
11501         j2=j-2
11502       endif
11503       if (l.lt.nres-1) then
11504         l1=l+1
11505         l2=l-1
11506       else
11507         l1=l-1
11508         l2=l-2
11509       endif
11510       do ll=1,3
11511 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11512 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11513 !grad        ghalf=0.5d0*ggg1(ll)
11514 !d        ghalf=0.0d0
11515         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11516         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11517         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
11518           +ekont*derx_turn(ll,2,1)
11519         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11520         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
11521           +ekont*derx_turn(ll,4,1)
11522         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11523         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11524         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11525 !grad        ghalf=0.5d0*ggg2(ll)
11526 !d        ghalf=0.0d0
11527         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
11528           +ekont*derx_turn(ll,2,2)
11529         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11530         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
11531           +ekont*derx_turn(ll,4,2)
11532         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11533         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11534         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11535       enddo
11536 !d      goto 1112
11537 !grad      do m=i+1,j-1
11538 !grad        do ll=1,3
11539 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11540 !grad        enddo
11541 !grad      enddo
11542 !grad      do m=k+1,l-1
11543 !grad        do ll=1,3
11544 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11545 !grad        enddo
11546 !grad      enddo
11547 !grad1112  continue
11548 !grad      do m=i+2,j2
11549 !grad        do ll=1,3
11550 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11551 !grad        enddo
11552 !grad      enddo
11553 !grad      do m=k+2,l2
11554 !grad        do ll=1,3
11555 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11556 !grad        enddo
11557 !grad      enddo
11558 !d      do iii=1,nres-3
11559 !d        write (2,*) iii,g_corr6_loc(iii)
11560 !d      enddo
11561       eello_turn6=ekont*eel_turn6
11562 !d      write (2,*) 'ekont',ekont
11563 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
11564       return
11565       end function eello_turn6
11566 !-----------------------------------------------------------------------------
11567       subroutine MATVEC2(A1,V1,V2)
11568 !DIR$ INLINEALWAYS MATVEC2
11569 #ifndef OSF
11570 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11571 #endif
11572 !      implicit real*8 (a-h,o-z)
11573 !      include 'DIMENSIONS'
11574       real(kind=8),dimension(2) :: V1,V2
11575       real(kind=8),dimension(2,2) :: A1
11576       real(kind=8) :: vaux1,vaux2
11577 !      DO 1 I=1,2
11578 !        VI=0.0
11579 !        DO 3 K=1,2
11580 !    3     VI=VI+A1(I,K)*V1(K)
11581 !        Vaux(I)=VI
11582 !    1 CONTINUE
11583
11584       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11585       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11586
11587       v2(1)=vaux1
11588       v2(2)=vaux2
11589       end subroutine MATVEC2
11590 !-----------------------------------------------------------------------------
11591       subroutine MATMAT2(A1,A2,A3)
11592 #ifndef OSF
11593 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11594 #endif
11595 !      implicit real*8 (a-h,o-z)
11596 !      include 'DIMENSIONS'
11597       real(kind=8),dimension(2,2) :: A1,A2,A3
11598       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
11599 !      DIMENSION AI3(2,2)
11600 !        DO  J=1,2
11601 !          A3IJ=0.0
11602 !          DO K=1,2
11603 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11604 !          enddo
11605 !          A3(I,J)=A3IJ
11606 !       enddo
11607 !      enddo
11608
11609       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11610       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11611       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11612       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11613
11614       A3(1,1)=AI3_11
11615       A3(2,1)=AI3_21
11616       A3(1,2)=AI3_12
11617       A3(2,2)=AI3_22
11618       end subroutine MATMAT2
11619 !-----------------------------------------------------------------------------
11620       real(kind=8) function scalar2(u,v)
11621 !DIR$ INLINEALWAYS scalar2
11622       implicit none
11623       real(kind=8),dimension(2) :: u,v
11624       real(kind=8) :: sc
11625       integer :: i
11626       scalar2=u(1)*v(1)+u(2)*v(2)
11627       return
11628       end function scalar2
11629 !-----------------------------------------------------------------------------
11630       subroutine transpose2(a,at)
11631 !DIR$ INLINEALWAYS transpose2
11632 #ifndef OSF
11633 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
11634 #endif
11635       implicit none
11636       real(kind=8),dimension(2,2) :: a,at
11637       at(1,1)=a(1,1)
11638       at(1,2)=a(2,1)
11639       at(2,1)=a(1,2)
11640       at(2,2)=a(2,2)
11641       return
11642       end subroutine transpose2
11643 !-----------------------------------------------------------------------------
11644       subroutine transpose(n,a,at)
11645       implicit none
11646       integer :: n,i,j
11647       real(kind=8),dimension(n,n) :: a,at
11648       do i=1,n
11649         do j=1,n
11650           at(j,i)=a(i,j)
11651         enddo
11652       enddo
11653       return
11654       end subroutine transpose
11655 !-----------------------------------------------------------------------------
11656       subroutine prodmat3(a1,a2,kk,transp,prod)
11657 !DIR$ INLINEALWAYS prodmat3
11658 #ifndef OSF
11659 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
11660 #endif
11661       implicit none
11662       integer :: i,j
11663       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
11664       logical :: transp
11665 !rc      double precision auxmat(2,2),prod_(2,2)
11666
11667       if (transp) then
11668 !rc        call transpose2(kk(1,1),auxmat(1,1))
11669 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11670 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11671
11672            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
11673        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11674            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
11675        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11676            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
11677        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11678            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
11679        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11680
11681       else
11682 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11683 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11684
11685            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
11686         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11687            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
11688         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11689            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
11690         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11691            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
11692         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11693
11694       endif
11695 !      call transpose2(a2(1,1),a2t(1,1))
11696
11697 !rc      print *,transp
11698 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
11699 !rc      print *,((prod(i,j),i=1,2),j=1,2)
11700
11701       return
11702       end subroutine prodmat3
11703 !-----------------------------------------------------------------------------
11704 ! energy_p_new_barrier.F
11705 !-----------------------------------------------------------------------------
11706       subroutine sum_gradient
11707 !      implicit real*8 (a-h,o-z)
11708       use io_base, only: pdbout
11709 !      include 'DIMENSIONS'
11710 #ifndef ISNAN
11711       external proc_proc
11712 #ifdef WINPGI
11713 !MS$ATTRIBUTES C ::  proc_proc
11714 #endif
11715 #endif
11716 #ifdef MPI
11717       include 'mpif.h'
11718 #endif
11719       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
11720                    gloc_scbuf !(3,maxres)
11721
11722       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
11723 !#endif
11724 !el local variables
11725       integer :: i,j,k,ierror,ierr
11726       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
11727                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
11728                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
11729                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
11730                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
11731                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
11732                    gsccorr_max,gsccorrx_max,time00
11733
11734 !      include 'COMMON.SETUP'
11735 !      include 'COMMON.IOUNITS'
11736 !      include 'COMMON.FFIELD'
11737 !      include 'COMMON.DERIV'
11738 !      include 'COMMON.INTERACT'
11739 !      include 'COMMON.SBRIDGE'
11740 !      include 'COMMON.CHAIN'
11741 !      include 'COMMON.VAR'
11742 !      include 'COMMON.CONTROL'
11743 !      include 'COMMON.TIME1'
11744 !      include 'COMMON.MAXGRAD'
11745 !      include 'COMMON.SCCOR'
11746 #ifdef TIMING
11747       time01=MPI_Wtime()
11748 #endif
11749 !#define DEBUG
11750 #ifdef DEBUG
11751       write (iout,*) "sum_gradient gvdwc, gvdwx"
11752       do i=1,nres
11753         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11754          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
11755       enddo
11756       call flush(iout)
11757 #endif
11758 #ifdef MPI
11759         gradbufc=0.0d0
11760         gradbufx=0.0d0
11761         gradbufc_sum=0.0d0
11762         gloc_scbuf=0.0d0
11763         glocbuf=0.0d0
11764 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
11765         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
11766           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
11767 #endif
11768 !
11769 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
11770 !            in virtual-bond-vector coordinates
11771 !
11772 #ifdef DEBUG
11773 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
11774 !      do i=1,nres-1
11775 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
11776 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
11777 !      enddo
11778 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
11779 !      do i=1,nres-1
11780 !        write (iout,'(i5,3f10.5,2x,f10.5)')
11781 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
11782 !      enddo
11783 !      write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
11784 !      do i=1,nres
11785 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11786 !         i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
11787 !         (gvdwc_scpp(j,i),j=1,3)
11788 !      enddo
11789 !      write (iout,*) "gelc_long gvdwpp gel_loc_long"
11790 !      do i=1,nres
11791 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11792 !         i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
11793 !         (gelc_loc_long(j,i),j=1,3)
11794 !      enddo
11795       call flush(iout)
11796 #endif
11797 #ifdef SPLITELE
11798       do i=0,nct
11799         do j=1,3
11800           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11801                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11802                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11803                       wel_loc*gel_loc_long(j,i)+ &
11804                       wcorr*gradcorr_long(j,i)+ &
11805                       wcorr5*gradcorr5_long(j,i)+ &
11806                       wcorr6*gradcorr6_long(j,i)+ &
11807                       wturn6*gcorr6_turn_long(j,i)+ &
11808                       wstrain*ghpbc(j,i) &
11809                      +wliptran*gliptranc(j,i) &
11810                      +gradafm(j,i) &
11811                      +welec*gshieldc(j,i) &
11812                      +wcorr*gshieldc_ec(j,i) &
11813                      +wturn3*gshieldc_t3(j,i)&
11814                      +wturn4*gshieldc_t4(j,i)&
11815                      +wel_loc*gshieldc_ll(j,i)&
11816                      +wtube*gg_tube(j,i) &
11817                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11818                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11819                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11820                      wcorr_nucl*gradcorr_nucl(j,i)&
11821                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
11822                      wcatprot* gradpepcat(j,i)+ &
11823                      wcatcat*gradcatcat(j,i)+   &
11824                      wscbase*gvdwc_scbase(j,i)+ &
11825                      wpepbase*gvdwc_pepbase(j,i)+&
11826                      wscpho*gvdwc_scpho(j,i)+   &
11827                      wpeppho*gvdwc_peppho(j,i)+wcatnucl*gradnuclcat(j,i)
11828
11829
11830
11831
11832
11833         enddo
11834       enddo
11835 #else
11836       do i=0,nct
11837         do j=1,3
11838           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11839                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11840                       welec*gelc_long(j,i)+ &
11841                       wbond*gradb(j,i)+ &
11842                       wel_loc*gel_loc_long(j,i)+ &
11843                       wcorr*gradcorr_long(j,i)+ &
11844                       wcorr5*gradcorr5_long(j,i)+ &
11845                       wcorr6*gradcorr6_long(j,i)+ &
11846                       wturn6*gcorr6_turn_long(j,i)+ &
11847                       wstrain*ghpbc(j,i) &
11848                      +wliptran*gliptranc(j,i) &
11849                      +gradafm(j,i) &
11850                      +welec*gshieldc(j,i)&
11851                      +wcorr*gshieldc_ec(j,i) &
11852                      +wturn4*gshieldc_t4(j,i) &
11853                      +wel_loc*gshieldc_ll(j,i)&
11854                      +wtube*gg_tube(j,i) &
11855                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11856                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11857                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11858                      wcorr_nucl*gradcorr_nucl(j,i) &
11859                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
11860                      wcatprot* gradpepcat(j,i)+ &
11861                      wcatcat*gradcatcat(j,i)+   &
11862                      wscbase*gvdwc_scbase(j,i)+ &
11863                      wpepbase*gvdwc_pepbase(j,i)+&
11864                      wscpho*gvdwc_scpho(j,i)+&
11865                      wpeppho*gvdwc_peppho(j,i)+wcatnucl*gradnuclcat(j,i)
11866
11867
11868         enddo
11869       enddo
11870 #endif
11871 #ifdef MPI
11872       if (nfgtasks.gt.1) then
11873       time00=MPI_Wtime()
11874 #ifdef DEBUG
11875       write (iout,*) "gradbufc before allreduce"
11876       do i=1,nres
11877         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11878       enddo
11879       call flush(iout)
11880 #endif
11881       do i=0,nres
11882         do j=1,3
11883           gradbufc_sum(j,i)=gradbufc(j,i)
11884         enddo
11885       enddo
11886 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
11887 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
11888 !      time_reduce=time_reduce+MPI_Wtime()-time00
11889 #ifdef DEBUG
11890 !      write (iout,*) "gradbufc_sum after allreduce"
11891 !      do i=1,nres
11892 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
11893 !      enddo
11894 !      call flush(iout)
11895 #endif
11896 #ifdef TIMING
11897 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
11898 #endif
11899       do i=0,nres
11900         do k=1,3
11901           gradbufc(k,i)=0.0d0
11902         enddo
11903       enddo
11904 #ifdef DEBUG
11905       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
11906       write (iout,*) (i," jgrad_start",jgrad_start(i),&
11907                         " jgrad_end  ",jgrad_end(i),&
11908                         i=igrad_start,igrad_end)
11909 #endif
11910 !
11911 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
11912 ! do not parallelize this part.
11913 !
11914 !      do i=igrad_start,igrad_end
11915 !        do j=jgrad_start(i),jgrad_end(i)
11916 !          do k=1,3
11917 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
11918 !          enddo
11919 !        enddo
11920 !      enddo
11921       do j=1,3
11922         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11923       enddo
11924       do i=nres-2,-1,-1
11925         do j=1,3
11926           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11927         enddo
11928       enddo
11929 #ifdef DEBUG
11930       write (iout,*) "gradbufc after summing"
11931       do i=1,nres
11932         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11933       enddo
11934       call flush(iout)
11935 #endif
11936       else
11937 #endif
11938 !el#define DEBUG
11939 #ifdef DEBUG
11940       write (iout,*) "gradbufc"
11941       do i=1,nres
11942         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11943       enddo
11944       call flush(iout)
11945 #endif
11946 !el#undef DEBUG
11947       do i=-1,nres
11948         do j=1,3
11949           gradbufc_sum(j,i)=gradbufc(j,i)
11950           gradbufc(j,i)=0.0d0
11951         enddo
11952       enddo
11953       do j=1,3
11954         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11955       enddo
11956       do i=nres-2,-1,-1
11957         do j=1,3
11958           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11959         enddo
11960       enddo
11961 !      do i=nnt,nres-1
11962 !        do k=1,3
11963 !          gradbufc(k,i)=0.0d0
11964 !        enddo
11965 !        do j=i+1,nres
11966 !          do k=1,3
11967 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
11968 !          enddo
11969 !        enddo
11970 !      enddo
11971 !el#define DEBUG
11972 #ifdef DEBUG
11973       write (iout,*) "gradbufc after summing"
11974       do i=1,nres
11975         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11976       enddo
11977       call flush(iout)
11978 #endif
11979 !el#undef DEBUG
11980 #ifdef MPI
11981       endif
11982 #endif
11983       do k=1,3
11984         gradbufc(k,nres)=0.0d0
11985       enddo
11986 !el----------------
11987 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
11988 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
11989 !el-----------------
11990       do i=-1,nct
11991         do j=1,3
11992 #ifdef SPLITELE
11993           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11994                       wel_loc*gel_loc(j,i)+ &
11995                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11996                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11997                       wel_loc*gel_loc_long(j,i)+ &
11998                       wcorr*gradcorr_long(j,i)+ &
11999                       wcorr5*gradcorr5_long(j,i)+ &
12000                       wcorr6*gradcorr6_long(j,i)+ &
12001                       wturn6*gcorr6_turn_long(j,i))+ &
12002                       wbond*gradb(j,i)+ &
12003                       wcorr*gradcorr(j,i)+ &
12004                       wturn3*gcorr3_turn(j,i)+ &
12005                       wturn4*gcorr4_turn(j,i)+ &
12006                       wcorr5*gradcorr5(j,i)+ &
12007                       wcorr6*gradcorr6(j,i)+ &
12008                       wturn6*gcorr6_turn(j,i)+ &
12009                       wsccor*gsccorc(j,i) &
12010                      +wscloc*gscloc(j,i)  &
12011                      +wliptran*gliptranc(j,i) &
12012                      +gradafm(j,i) &
12013                      +welec*gshieldc(j,i) &
12014                      +welec*gshieldc_loc(j,i) &
12015                      +wcorr*gshieldc_ec(j,i) &
12016                      +wcorr*gshieldc_loc_ec(j,i) &
12017                      +wturn3*gshieldc_t3(j,i) &
12018                      +wturn3*gshieldc_loc_t3(j,i) &
12019                      +wturn4*gshieldc_t4(j,i) &
12020                      +wturn4*gshieldc_loc_t4(j,i) &
12021                      +wel_loc*gshieldc_ll(j,i) &
12022                      +wel_loc*gshieldc_loc_ll(j,i) &
12023                      +wtube*gg_tube(j,i) &
12024                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
12025                      +wvdwpsb*gvdwpsb1(j,i))&
12026                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
12027 !                      if (i.eq.21) then
12028 !                      print *,"in sum",gradc(j,i,icg),wturn4*gcorr4_turn(j,i),&
12029 !                      wturn4*gshieldc_t4(j,i), &
12030 !                     wturn4*gshieldc_loc_t4(j,i)
12031 !                       endif
12032 !                 if ((i.le.2).and.(i.ge.1))
12033 !                       print *,gradc(j,i,icg),&
12034 !                      gradbufc(j,i),welec*gelc(j,i), &
12035 !                      wel_loc*gel_loc(j,i), &
12036 !                      wscp*gvdwc_scpp(j,i), &
12037 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
12038 !                      wel_loc*gel_loc_long(j,i), &
12039 !                      wcorr*gradcorr_long(j,i), &
12040 !                      wcorr5*gradcorr5_long(j,i), &
12041 !                      wcorr6*gradcorr6_long(j,i), &
12042 !                      wturn6*gcorr6_turn_long(j,i), &
12043 !                      wbond*gradb(j,i), &
12044 !                      wcorr*gradcorr(j,i), &
12045 !                      wturn3*gcorr3_turn(j,i), &
12046 !                      wturn4*gcorr4_turn(j,i), &
12047 !                      wcorr5*gradcorr5(j,i), &
12048 !                      wcorr6*gradcorr6(j,i), &
12049 !                      wturn6*gcorr6_turn(j,i), &
12050 !                      wsccor*gsccorc(j,i) &
12051 !                     ,wscloc*gscloc(j,i)  &
12052 !                     ,wliptran*gliptranc(j,i) &
12053 !                    ,gradafm(j,i) &
12054 !                     ,welec*gshieldc(j,i) &
12055 !                     ,welec*gshieldc_loc(j,i) &
12056 !                     ,wcorr*gshieldc_ec(j,i) &
12057 !                     ,wcorr*gshieldc_loc_ec(j,i) &
12058 !                     ,wturn3*gshieldc_t3(j,i) &
12059 !                     ,wturn3*gshieldc_loc_t3(j,i) &
12060 !                     ,wturn4*gshieldc_t4(j,i) &
12061 !                     ,wturn4*gshieldc_loc_t4(j,i) &
12062 !                     ,wel_loc*gshieldc_ll(j,i) &
12063 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
12064 !                     ,wtube*gg_tube(j,i) &
12065 !                     ,wbond_nucl*gradb_nucl(j,i) &
12066 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
12067 !                     wvdwpsb*gvdwpsb1(j,i)&
12068 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
12069 !
12070
12071 #else
12072           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
12073                       wel_loc*gel_loc(j,i)+ &
12074                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
12075                       welec*gelc_long(j,i)+ &
12076                       wel_loc*gel_loc_long(j,i)+ &
12077 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
12078                       wcorr5*gradcorr5_long(j,i)+ &
12079                       wcorr6*gradcorr6_long(j,i)+ &
12080                       wturn6*gcorr6_turn_long(j,i))+ &
12081                       wbond*gradb(j,i)+ &
12082                       wcorr*gradcorr(j,i)+ &
12083                       wturn3*gcorr3_turn(j,i)+ &
12084                       wturn4*gcorr4_turn(j,i)+ &
12085                       wcorr5*gradcorr5(j,i)+ &
12086                       wcorr6*gradcorr6(j,i)+ &
12087                       wturn6*gcorr6_turn(j,i)+ &
12088                       wsccor*gsccorc(j,i) &
12089                      +wscloc*gscloc(j,i) &
12090                      +gradafm(j,i) &
12091                      +wliptran*gliptranc(j,i) &
12092                      +welec*gshieldc(j,i) &
12093                      +welec*gshieldc_loc(j,i) &
12094                      +wcorr*gshieldc_ec(j,i) &
12095                      +wcorr*gshieldc_loc_ec(j,i) &
12096                      +wturn3*gshieldc_t3(j,i) &
12097                      +wturn3*gshieldc_loc_t3(j,i) &
12098                      +wturn4*gshieldc_t4(j,i) &
12099                      +wturn4*gshieldc_loc_t4(j,i) &
12100                      +wel_loc*gshieldc_ll(j,i) &
12101                      +wel_loc*gshieldc_loc_ll(j,i) &
12102                      +wtube*gg_tube(j,i) &
12103                      +wbond_nucl*gradb_nucl(j,i) &
12104                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
12105                      +wvdwpsb*gvdwpsb1(j,i))&
12106                      +wsbloc*gsbloc(j,i)+wcatnucl*gradnuclcat(j,i)
12107
12108
12109
12110
12111 #endif
12112           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
12113                         wbond*gradbx(j,i)+ &
12114                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
12115                         wsccor*gsccorx(j,i) &
12116                        +wscloc*gsclocx(j,i) &
12117                        +wliptran*gliptranx(j,i) &
12118                        +welec*gshieldx(j,i)     &
12119                        +wcorr*gshieldx_ec(j,i)  &
12120                        +wturn3*gshieldx_t3(j,i) &
12121                        +wturn4*gshieldx_t4(j,i) &
12122                        +wel_loc*gshieldx_ll(j,i)&
12123                        +wtube*gg_tube_sc(j,i)   &
12124                        +wbond_nucl*gradbx_nucl(j,i) &
12125                        +wvdwsb*gvdwsbx(j,i) &
12126                        +welsb*gelsbx(j,i) &
12127                        +wcorr_nucl*gradxorr_nucl(j,i)&
12128                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
12129                        +wsbloc*gsblocx(j,i) &
12130                        +wcatprot* gradpepcatx(j,i)&
12131                        +wscbase*gvdwx_scbase(j,i) &
12132                        +wpepbase*gvdwx_pepbase(j,i)&
12133                        +wscpho*gvdwx_scpho(j,i)+wcatnucl*gradnuclcatx(j,i)
12134 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
12135
12136         enddo
12137       enddo
12138 !      write(iout,*), "const_homol",constr_homology
12139       if (constr_homology.gt.0) then
12140         do i=1,nct
12141           do j=1,3
12142             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
12143 !            write(iout,*) "duscdiff",duscdiff(j,i)
12144             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
12145           enddo
12146         enddo
12147       endif
12148 !#define DEBUG
12149 #ifdef DEBUG
12150       write (iout,*) "gloc before adding corr"
12151       do i=1,4*nres
12152         write (iout,*) i,gloc(i,icg)
12153       enddo
12154 #endif
12155       do i=1,nres-3
12156         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
12157          +wcorr5*g_corr5_loc(i) &
12158          +wcorr6*g_corr6_loc(i) &
12159          +wturn4*gel_loc_turn4(i) &
12160          +wturn3*gel_loc_turn3(i) &
12161          +wturn6*gel_loc_turn6(i) &
12162          +wel_loc*gel_loc_loc(i)
12163       enddo
12164 #ifdef DEBUG
12165       write (iout,*) "gloc after adding corr"
12166       do i=1,4*nres
12167         write (iout,*) i,gloc(i,icg)
12168       enddo
12169 #endif
12170 !#undef DEBUG
12171 #ifdef MPI
12172       if (nfgtasks.gt.1) then
12173         do j=1,3
12174           do i=0,nres
12175             gradbufc(j,i)=gradc(j,i,icg)
12176             gradbufx(j,i)=gradx(j,i,icg)
12177           enddo
12178         enddo
12179         do i=1,4*nres
12180           glocbuf(i)=gloc(i,icg)
12181         enddo
12182 !#define DEBUG
12183 #ifdef DEBUG
12184       write (iout,*) "gloc_sc before reduce"
12185       do i=1,nres
12186        do j=1,1
12187         write (iout,*) i,j,gloc_sc(j,i,icg)
12188        enddo
12189       enddo
12190 #endif
12191 !#undef DEBUG
12192         do i=0,nres
12193          do j=1,3
12194           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
12195          enddo
12196         enddo
12197         time00=MPI_Wtime()
12198         call MPI_Barrier(FG_COMM,IERR)
12199         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
12200         time00=MPI_Wtime()
12201         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
12202           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12203         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
12204           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12205         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
12206           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12207         time_reduce=time_reduce+MPI_Wtime()-time00
12208         call MPI_Reduce(gloc_scbuf(1,0),gloc_sc(1,0,icg),3*nres+3,&
12209           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12210         time_reduce=time_reduce+MPI_Wtime()-time00
12211 !#define DEBUG
12212 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
12213 #ifdef DEBUG
12214       write (iout,*) "gloc_sc after reduce"
12215       do i=0,nres
12216        do j=1,1
12217         write (iout,*) i,j,gloc_sc(j,i,icg)
12218        enddo
12219       enddo
12220 #endif
12221 !#undef DEBUG
12222 #ifdef DEBUG
12223       write (iout,*) "gloc after reduce"
12224       do i=1,4*nres
12225         write (iout,*) i,gloc(i,icg)
12226       enddo
12227 #endif
12228       endif
12229 #endif
12230       if (gnorm_check) then
12231 !
12232 ! Compute the maximum elements of the gradient
12233 !
12234       gvdwc_max=0.0d0
12235       gvdwc_scp_max=0.0d0
12236       gelc_max=0.0d0
12237       gvdwpp_max=0.0d0
12238       gradb_max=0.0d0
12239       ghpbc_max=0.0d0
12240       gradcorr_max=0.0d0
12241       gel_loc_max=0.0d0
12242       gcorr3_turn_max=0.0d0
12243       gcorr4_turn_max=0.0d0
12244       gradcorr5_max=0.0d0
12245       gradcorr6_max=0.0d0
12246       gcorr6_turn_max=0.0d0
12247       gsccorc_max=0.0d0
12248       gscloc_max=0.0d0
12249       gvdwx_max=0.0d0
12250       gradx_scp_max=0.0d0
12251       ghpbx_max=0.0d0
12252       gradxorr_max=0.0d0
12253       gsccorx_max=0.0d0
12254       gsclocx_max=0.0d0
12255       do i=1,nct
12256         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
12257         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
12258         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
12259         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
12260          gvdwc_scp_max=gvdwc_scp_norm
12261         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
12262         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
12263         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
12264         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
12265         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
12266         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
12267         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
12268         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
12269         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
12270         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
12271         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
12272         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
12273         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
12274           gcorr3_turn(1,i)))
12275         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
12276           gcorr3_turn_max=gcorr3_turn_norm
12277         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
12278           gcorr4_turn(1,i)))
12279         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
12280           gcorr4_turn_max=gcorr4_turn_norm
12281         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
12282         if (gradcorr5_norm.gt.gradcorr5_max) &
12283           gradcorr5_max=gradcorr5_norm
12284         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
12285         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
12286         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
12287           gcorr6_turn(1,i)))
12288         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
12289           gcorr6_turn_max=gcorr6_turn_norm
12290         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
12291         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
12292         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
12293         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
12294         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
12295         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
12296         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
12297         if (gradx_scp_norm.gt.gradx_scp_max) &
12298           gradx_scp_max=gradx_scp_norm
12299         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
12300         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
12301         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
12302         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
12303         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
12304         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
12305         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
12306         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
12307       enddo
12308       if (gradout) then
12309 #ifdef AIX
12310         open(istat,file=statname,position="append")
12311 #else
12312         open(istat,file=statname,access="append")
12313 #endif
12314         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
12315            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
12316            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
12317            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
12318            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
12319            gsccorx_max,gsclocx_max
12320         close(istat)
12321         if (gvdwc_max.gt.1.0d4) then
12322           write (iout,*) "gvdwc gvdwx gradb gradbx"
12323           do i=nnt,nct
12324             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
12325               gradb(j,i),gradbx(j,i),j=1,3)
12326           enddo
12327           call pdbout(0.0d0,'cipiszcze',iout)
12328           call flush(iout)
12329         endif
12330       endif
12331       endif
12332 !#define DEBUG
12333 #ifdef DEBUG
12334       write (iout,*) "gradc gradx gloc"
12335       do i=1,nres
12336         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
12337          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
12338       enddo
12339 #endif
12340 !#undef DEBUG
12341 #ifdef TIMING
12342       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
12343 #endif
12344       return
12345       end subroutine sum_gradient
12346 !-----------------------------------------------------------------------------
12347       subroutine sc_grad
12348 !      implicit real*8 (a-h,o-z)
12349       use calc_data
12350 !      include 'DIMENSIONS'
12351 !      include 'COMMON.CHAIN'
12352 !      include 'COMMON.DERIV'
12353 !      include 'COMMON.CALC'
12354 !      include 'COMMON.IOUNITS'
12355       real(kind=8), dimension(3) :: dcosom1,dcosom2
12356 !      print *,"wchodze"
12357       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
12358           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
12359       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
12360           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
12361
12362       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
12363            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
12364            +dCAVdOM12+ dGCLdOM12
12365 ! diagnostics only
12366 !      eom1=0.0d0
12367 !      eom2=0.0d0
12368 !      eom12=evdwij*eps1_om12
12369 ! end diagnostics
12370 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
12371 !       " sigder",sigder
12372 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
12373 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
12374 !C      print *,sss_ele_cut,'in sc_grad'
12375       do k=1,3
12376         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
12377         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
12378       enddo
12379       do k=1,3
12380         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
12381 !C      print *,'gg',k,gg(k)
12382        enddo
12383 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
12384 !      write (iout,*) "gg",(gg(k),k=1,3)
12385       do k=1,3
12386         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
12387                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
12388                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
12389                   *sss_ele_cut
12390
12391         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
12392                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
12393                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
12394                   *sss_ele_cut
12395
12396 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
12397 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
12398 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
12399 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
12400       enddo
12401 !
12402 ! Calculate the components of the gradient in DC and X
12403 !
12404 !grad      do k=i,j-1
12405 !grad        do l=1,3
12406 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
12407 !grad        enddo
12408 !grad      enddo
12409       do l=1,3
12410         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
12411         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
12412       enddo
12413       return
12414       end subroutine sc_grad
12415
12416       subroutine sc_grad_cat
12417       use calc_data
12418       real(kind=8), dimension(3) :: dcosom1,dcosom2
12419       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
12420           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
12421       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
12422           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
12423
12424       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
12425            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
12426            +dCAVdOM12+ dGCLdOM12
12427 ! diagnostics only
12428 !      eom1=0.0d0
12429 !      eom2=0.0d0
12430 !      eom12=evdwij*eps1_om12
12431 ! end diagnostics
12432
12433       do k=1,3
12434         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
12435         dcosom2(k)=rij*(dc_norm(k,j)-om2*erij(k))
12436       enddo
12437       do k=1,3
12438         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))
12439 !C      print *,'gg',k,gg(k)
12440        enddo
12441 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
12442 !      write (iout,*) "gg",(gg(k),k=1,3)
12443       do k=1,3
12444         gradpepcatx(k,i)=gradpepcatx(k,i)-gg(k) &
12445                   +(eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
12446                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
12447
12448 !        gradpepcatx(k,j)=gradpepcatx(k,j)+gg(k) &
12449 !                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)) &
12450 !                  +eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv
12451
12452 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
12453 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
12454 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
12455 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
12456       enddo
12457 !
12458 ! Calculate the components of the gradient in DC and X
12459 !
12460       do l=1,3
12461         gradpepcat(l,i)=gradpepcat(l,i)-gg(l)
12462         gradpepcat(l,j)=gradpepcat(l,j)+gg(l)
12463       enddo
12464       end subroutine sc_grad_cat
12465
12466       subroutine sc_grad_cat_pep
12467       use calc_data
12468       real(kind=8), dimension(3) :: dcosom1,dcosom2
12469       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
12470           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
12471       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
12472           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
12473
12474       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
12475            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
12476            +dCAVdOM12+ dGCLdOM12
12477 ! diagnostics only
12478 !      eom1=0.0d0
12479 !      eom2=0.0d0
12480 !      eom12=evdwij*eps1_om12
12481 ! end diagnostics
12482
12483       do k=1,3
12484         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
12485         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
12486         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
12487         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
12488                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
12489                  *dsci_inv*2.0 &
12490                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
12491         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
12492                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
12493                  *dsci_inv*2.0 &
12494                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
12495         gradpepcat(k,j)=gradpepcat(k,j)+gg(k)
12496       enddo
12497       end subroutine sc_grad_cat_pep
12498
12499 #ifdef CRYST_THETA
12500 !-----------------------------------------------------------------------------
12501       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
12502
12503       use comm_calcthet
12504 !      implicit real*8 (a-h,o-z)
12505 !      include 'DIMENSIONS'
12506 !      include 'COMMON.LOCAL'
12507 !      include 'COMMON.IOUNITS'
12508 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
12509 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
12510 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
12511       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
12512       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
12513 !el      integer :: it
12514 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
12515 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
12516 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
12517 !el local variables
12518
12519       delthec=thetai-thet_pred_mean
12520       delthe0=thetai-theta0i
12521 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
12522       t3 = thetai-thet_pred_mean
12523       t6 = t3**2
12524       t9 = term1
12525       t12 = t3*sigcsq
12526       t14 = t12+t6*sigsqtc
12527       t16 = 1.0d0
12528       t21 = thetai-theta0i
12529       t23 = t21**2
12530       t26 = term2
12531       t27 = t21*t26
12532       t32 = termexp
12533       t40 = t32**2
12534       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
12535        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
12536        *(-t12*t9-ak*sig0inv*t27)
12537       return
12538       end subroutine mixder
12539 #endif
12540 !-----------------------------------------------------------------------------
12541 ! cartder.F
12542 !-----------------------------------------------------------------------------
12543       subroutine cartder
12544 !-----------------------------------------------------------------------------
12545 ! This subroutine calculates the derivatives of the consecutive virtual
12546 ! bond vectors and the SC vectors in the virtual-bond angles theta and
12547 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
12548 ! in the angles alpha and omega, describing the location of a side chain
12549 ! in its local coordinate system.
12550 !
12551 ! The derivatives are stored in the following arrays:
12552 !
12553 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
12554 ! The structure is as follows:
12555 !
12556 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
12557 ! 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)
12558 !         . . . . . . . . . . . .  . . . . . .
12559 ! 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)
12560 !                          .
12561 !                          .
12562 !                          .
12563 ! 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)
12564 !
12565 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
12566 ! The structure is same as above.
12567 !
12568 ! DCDS - the derivatives of the side chain vectors in the local spherical
12569 ! andgles alph and omega:
12570 !
12571 ! 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)
12572 ! 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)
12573 !                          .
12574 !                          .
12575 !                          .
12576 ! 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)
12577 !
12578 ! Version of March '95, based on an early version of November '91.
12579 !
12580 !**********************************************************************
12581 !      implicit real*8 (a-h,o-z)
12582 !      include 'DIMENSIONS'
12583 !      include 'COMMON.VAR'
12584 !      include 'COMMON.CHAIN'
12585 !      include 'COMMON.DERIV'
12586 !      include 'COMMON.GEO'
12587 !      include 'COMMON.LOCAL'
12588 !      include 'COMMON.INTERACT'
12589       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
12590       real(kind=8),dimension(3,3) :: dp,temp
12591 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
12592       real(kind=8),dimension(3) :: xx,xx1
12593 !el local variables
12594       integer :: i,k,l,j,m,ind,ind1,jjj
12595       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
12596                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
12597                  sint2,xp,yp,xxp,yyp,zzp,dj
12598
12599 !      common /przechowalnia/ fromto
12600       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
12601 ! get the position of the jth ijth fragment of the chain coordinate system
12602 ! in the fromto array.
12603 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12604 !
12605 !      maxdim=(nres-1)*(nres-2)/2
12606 !      allocate(dcdv(6,maxdim),dxds(6,nres))
12607 ! calculate the derivatives of transformation matrix elements in theta
12608 !
12609
12610 !el      call flush(iout) !el
12611       do i=1,nres-2
12612         rdt(1,1,i)=-rt(1,2,i)
12613         rdt(1,2,i)= rt(1,1,i)
12614         rdt(1,3,i)= 0.0d0
12615         rdt(2,1,i)=-rt(2,2,i)
12616         rdt(2,2,i)= rt(2,1,i)
12617         rdt(2,3,i)= 0.0d0
12618         rdt(3,1,i)=-rt(3,2,i)
12619         rdt(3,2,i)= rt(3,1,i)
12620         rdt(3,3,i)= 0.0d0
12621       enddo
12622 !
12623 ! derivatives in phi
12624 !
12625       do i=2,nres-2
12626         drt(1,1,i)= 0.0d0
12627         drt(1,2,i)= 0.0d0
12628         drt(1,3,i)= 0.0d0
12629         drt(2,1,i)= rt(3,1,i)
12630         drt(2,2,i)= rt(3,2,i)
12631         drt(2,3,i)= rt(3,3,i)
12632         drt(3,1,i)=-rt(2,1,i)
12633         drt(3,2,i)=-rt(2,2,i)
12634         drt(3,3,i)=-rt(2,3,i)
12635       enddo
12636 !
12637 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
12638 !
12639       do i=2,nres-2
12640         ind=indmat(i,i+1)
12641         do k=1,3
12642           do l=1,3
12643             temp(k,l)=rt(k,l,i)
12644           enddo
12645         enddo
12646         do k=1,3
12647           do l=1,3
12648             fromto(k,l,ind)=temp(k,l)
12649           enddo
12650         enddo
12651         do j=i+1,nres-2
12652           ind=indmat(i,j+1)
12653           do k=1,3
12654             do l=1,3
12655               dpkl=0.0d0
12656               do m=1,3
12657                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
12658               enddo
12659               dp(k,l)=dpkl
12660               fromto(k,l,ind)=dpkl
12661             enddo
12662           enddo
12663           do k=1,3
12664             do l=1,3
12665               temp(k,l)=dp(k,l)
12666             enddo
12667           enddo
12668         enddo
12669       enddo
12670 !
12671 ! Calculate derivatives.
12672 !
12673       ind1=0
12674       do i=1,nres-2
12675       ind1=ind1+1
12676 !
12677 ! Derivatives of DC(i+1) in theta(i+2)
12678 !
12679         do j=1,3
12680           do k=1,2
12681             dpjk=0.0D0
12682             do l=1,3
12683               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
12684             enddo
12685             dp(j,k)=dpjk
12686             prordt(j,k,i)=dp(j,k)
12687           enddo
12688           dp(j,3)=0.0D0
12689           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
12690         enddo
12691 !
12692 ! Derivatives of SC(i+1) in theta(i+2)
12693 !
12694         xx1(1)=-0.5D0*xloc(2,i+1)
12695         xx1(2)= 0.5D0*xloc(1,i+1)
12696         do j=1,3
12697           xj=0.0D0
12698           do k=1,2
12699             xj=xj+r(j,k,i)*xx1(k)
12700           enddo
12701           xx(j)=xj
12702         enddo
12703         do j=1,3
12704           rj=0.0D0
12705           do k=1,3
12706             rj=rj+prod(j,k,i)*xx(k)
12707           enddo
12708           dxdv(j,ind1)=rj
12709         enddo
12710 !
12711 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
12712 ! than the other off-diagonal derivatives.
12713 !
12714         do j=1,3
12715           dxoiij=0.0D0
12716           do k=1,3
12717             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12718           enddo
12719           dxdv(j,ind1+1)=dxoiij
12720         enddo
12721 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
12722 !
12723 ! Derivatives of DC(i+1) in phi(i+2)
12724 !
12725         do j=1,3
12726           do k=1,3
12727             dpjk=0.0
12728             do l=2,3
12729               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
12730             enddo
12731             dp(j,k)=dpjk
12732             prodrt(j,k,i)=dp(j,k)
12733           enddo
12734           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
12735         enddo
12736 !
12737 ! Derivatives of SC(i+1) in phi(i+2)
12738 !
12739         xx(1)= 0.0D0
12740         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
12741         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
12742         do j=1,3
12743           rj=0.0D0
12744           do k=2,3
12745             rj=rj+prod(j,k,i)*xx(k)
12746           enddo
12747           dxdv(j+3,ind1)=-rj
12748         enddo
12749 !
12750 ! Derivatives of SC(i+1) in phi(i+3).
12751 !
12752         do j=1,3
12753           dxoiij=0.0D0
12754           do k=1,3
12755             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12756           enddo
12757           dxdv(j+3,ind1+1)=dxoiij
12758         enddo
12759 !
12760 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
12761 ! theta(nres) and phi(i+3) thru phi(nres).
12762 !
12763         do j=i+1,nres-2
12764         ind1=ind1+1
12765         ind=indmat(i+1,j+1)
12766 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
12767           do k=1,3
12768             do l=1,3
12769               tempkl=0.0D0
12770               do m=1,2
12771                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
12772               enddo
12773               temp(k,l)=tempkl
12774             enddo
12775           enddo
12776 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
12777 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
12778 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
12779 ! Derivatives of virtual-bond vectors in theta
12780           do k=1,3
12781             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
12782           enddo
12783 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
12784 ! Derivatives of SC vectors in theta
12785           do k=1,3
12786             dxoijk=0.0D0
12787             do l=1,3
12788               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12789             enddo
12790             dxdv(k,ind1+1)=dxoijk
12791           enddo
12792 !
12793 !--- Calculate the derivatives in phi
12794 !
12795           do k=1,3
12796             do l=1,3
12797               tempkl=0.0D0
12798               do m=1,3
12799                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
12800               enddo
12801               temp(k,l)=tempkl
12802             enddo
12803           enddo
12804           do k=1,3
12805             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
12806         enddo
12807           do k=1,3
12808             dxoijk=0.0D0
12809             do l=1,3
12810               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12811             enddo
12812             dxdv(k+3,ind1+1)=dxoijk
12813           enddo
12814         enddo
12815       enddo
12816 !
12817 ! Derivatives in alpha and omega:
12818 !
12819       do i=2,nres-1
12820 !       dsci=dsc(itype(i,1))
12821         dsci=vbld(i+nres)
12822 #ifdef OSF
12823         alphi=alph(i)
12824         omegi=omeg(i)
12825         if(alphi.ne.alphi) alphi=100.0
12826         if(omegi.ne.omegi) omegi=-100.0
12827 #else
12828       alphi=alph(i)
12829       omegi=omeg(i)
12830 #endif
12831 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
12832       cosalphi=dcos(alphi)
12833       sinalphi=dsin(alphi)
12834       cosomegi=dcos(omegi)
12835       sinomegi=dsin(omegi)
12836       temp(1,1)=-dsci*sinalphi
12837       temp(2,1)= dsci*cosalphi*cosomegi
12838       temp(3,1)=-dsci*cosalphi*sinomegi
12839       temp(1,2)=0.0D0
12840       temp(2,2)=-dsci*sinalphi*sinomegi
12841       temp(3,2)=-dsci*sinalphi*cosomegi
12842       theta2=pi-0.5D0*theta(i+1)
12843       cost2=dcos(theta2)
12844       sint2=dsin(theta2)
12845       jjj=0
12846 !d      print *,((temp(l,k),l=1,3),k=1,2)
12847         do j=1,2
12848         xp=temp(1,j)
12849         yp=temp(2,j)
12850         xxp= xp*cost2+yp*sint2
12851         yyp=-xp*sint2+yp*cost2
12852         zzp=temp(3,j)
12853         xx(1)=xxp
12854         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
12855         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
12856         do k=1,3
12857           dj=0.0D0
12858           do l=1,3
12859             dj=dj+prod(k,l,i-1)*xx(l)
12860             enddo
12861           dxds(jjj+k,i)=dj
12862           enddo
12863         jjj=jjj+3
12864       enddo
12865       enddo
12866       return
12867       end subroutine cartder
12868 !-----------------------------------------------------------------------------
12869 ! checkder_p.F
12870 !-----------------------------------------------------------------------------
12871       subroutine check_cartgrad
12872 ! Check the gradient of Cartesian coordinates in internal coordinates.
12873 !      implicit real*8 (a-h,o-z)
12874 !      include 'DIMENSIONS'
12875 !      include 'COMMON.IOUNITS'
12876 !      include 'COMMON.VAR'
12877 !      include 'COMMON.CHAIN'
12878 !      include 'COMMON.GEO'
12879 !      include 'COMMON.LOCAL'
12880 !      include 'COMMON.DERIV'
12881       real(kind=8),dimension(6,nres) :: temp
12882       real(kind=8),dimension(3) :: xx,gg
12883       integer :: i,k,j,ii
12884       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
12885 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12886 !
12887 ! Check the gradient of the virtual-bond and SC vectors in the internal
12888 ! coordinates.
12889 !
12890       aincr=1.0d-6
12891       aincr2=5.0d-7
12892       call cartder
12893       write (iout,'(a)') '**************** dx/dalpha'
12894       write (iout,'(a)')
12895       do i=2,nres-1
12896       alphi=alph(i)
12897       alph(i)=alph(i)+aincr
12898       do k=1,3
12899         temp(k,i)=dc(k,nres+i)
12900         enddo
12901       call chainbuild
12902       do k=1,3
12903         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12904         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
12905         enddo
12906         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12907         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
12908         write (iout,'(a)')
12909       alph(i)=alphi
12910       call chainbuild
12911       enddo
12912       write (iout,'(a)')
12913       write (iout,'(a)') '**************** dx/domega'
12914       write (iout,'(a)')
12915       do i=2,nres-1
12916       omegi=omeg(i)
12917       omeg(i)=omeg(i)+aincr
12918       do k=1,3
12919         temp(k,i)=dc(k,nres+i)
12920         enddo
12921       call chainbuild
12922       do k=1,3
12923           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12924           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
12925                 (aincr*dabs(dxds(k+3,i))+aincr))
12926         enddo
12927         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12928             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
12929         write (iout,'(a)')
12930       omeg(i)=omegi
12931       call chainbuild
12932       enddo
12933       write (iout,'(a)')
12934       write (iout,'(a)') '**************** dx/dtheta'
12935       write (iout,'(a)')
12936       do i=3,nres
12937       theti=theta(i)
12938         theta(i)=theta(i)+aincr
12939         do j=i-1,nres-1
12940           do k=1,3
12941             temp(k,j)=dc(k,nres+j)
12942           enddo
12943         enddo
12944         call chainbuild
12945         do j=i-1,nres-1
12946         ii = indmat(i-2,j)
12947 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
12948         do k=1,3
12949           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12950           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
12951                   (aincr*dabs(dxdv(k,ii))+aincr))
12952           enddo
12953           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12954               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
12955           write(iout,'(a)')
12956         enddo
12957         write (iout,'(a)')
12958         theta(i)=theti
12959         call chainbuild
12960       enddo
12961       write (iout,'(a)') '***************** dx/dphi'
12962       write (iout,'(a)')
12963       do i=4,nres
12964         phi(i)=phi(i)+aincr
12965         do j=i-1,nres-1
12966           do k=1,3
12967             temp(k,j)=dc(k,nres+j)
12968           enddo
12969         enddo
12970         call chainbuild
12971         do j=i-1,nres-1
12972         ii = indmat(i-2,j)
12973 !         print *,'ii=',ii
12974         do k=1,3
12975           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12976             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
12977                   (aincr*dabs(dxdv(k+3,ii))+aincr))
12978           enddo
12979           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12980               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12981           write(iout,'(a)')
12982         enddo
12983         phi(i)=phi(i)-aincr
12984         call chainbuild
12985       enddo
12986       write (iout,'(a)') '****************** ddc/dtheta'
12987       do i=1,nres-2
12988         thet=theta(i+2)
12989         theta(i+2)=thet+aincr
12990         do j=i,nres
12991           do k=1,3
12992             temp(k,j)=dc(k,j)
12993           enddo
12994         enddo
12995         call chainbuild
12996         do j=i+1,nres-1
12997         ii = indmat(i,j)
12998 !         print *,'ii=',ii
12999         do k=1,3
13000           gg(k)=(dc(k,j)-temp(k,j))/aincr
13001           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
13002                  (aincr*dabs(dcdv(k,ii))+aincr))
13003           enddo
13004           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
13005                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
13006         write (iout,'(a)')
13007         enddo
13008         do j=1,nres
13009           do k=1,3
13010             dc(k,j)=temp(k,j)
13011           enddo
13012         enddo
13013         theta(i+2)=thet
13014       enddo
13015       write (iout,'(a)') '******************* ddc/dphi'
13016       do i=1,nres-3
13017         phii=phi(i+3)
13018         phi(i+3)=phii+aincr
13019         do j=1,nres
13020           do k=1,3
13021             temp(k,j)=dc(k,j)
13022           enddo
13023         enddo
13024         call chainbuild
13025         do j=i+2,nres-1
13026         ii = indmat(i+1,j)
13027 !         print *,'ii=',ii
13028         do k=1,3
13029           gg(k)=(dc(k,j)-temp(k,j))/aincr
13030             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
13031                  (aincr*dabs(dcdv(k+3,ii))+aincr))
13032           enddo
13033           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
13034                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
13035         write (iout,'(a)')
13036         enddo
13037         do j=1,nres
13038           do k=1,3
13039             dc(k,j)=temp(k,j)
13040           enddo
13041         enddo
13042         phi(i+3)=phii
13043       enddo
13044       return
13045       end subroutine check_cartgrad
13046 !-----------------------------------------------------------------------------
13047       subroutine check_ecart
13048 ! Check the gradient of the energy in Cartesian coordinates.
13049 !     implicit real*8 (a-h,o-z)
13050 !     include 'DIMENSIONS'
13051 !     include 'COMMON.CHAIN'
13052 !     include 'COMMON.DERIV'
13053 !     include 'COMMON.IOUNITS'
13054 !     include 'COMMON.VAR'
13055 !     include 'COMMON.CONTACTS'
13056       use comm_srutu
13057 !el      integer :: icall
13058 !el      common /srutu/ icall
13059       real(kind=8),dimension(6) :: ggg
13060       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
13061       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
13062       real(kind=8),dimension(6,nres) :: grad_s
13063       real(kind=8),dimension(0:n_ene) :: energia,energia1
13064       integer :: uiparm(1)
13065       real(kind=8) :: urparm(1)
13066 !EL      external fdum
13067       integer :: nf,i,j,k
13068       real(kind=8) :: aincr,etot,etot1
13069       icg=1
13070       nf=0
13071       nfl=0
13072       call zerograd
13073       aincr=1.0D-5
13074       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
13075       nf=0
13076       icall=0
13077       call geom_to_var(nvar,x)
13078       call etotal(energia)
13079       etot=energia(0)
13080 !el      call enerprint(energia)
13081       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
13082       icall =1
13083       do i=1,nres
13084         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
13085       enddo
13086       do i=1,nres
13087       do j=1,3
13088         grad_s(j,i)=gradc(j,i,icg)
13089         grad_s(j+3,i)=gradx(j,i,icg)
13090         enddo
13091       enddo
13092       call flush(iout)
13093       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
13094       do i=1,nres
13095         do j=1,3
13096         xx(j)=c(j,i+nres)
13097         ddc(j)=dc(j,i)
13098         ddx(j)=dc(j,i+nres)
13099         enddo
13100       do j=1,3
13101         dc(j,i)=dc(j,i)+aincr
13102         do k=i+1,nres
13103           c(j,k)=c(j,k)+aincr
13104           c(j,k+nres)=c(j,k+nres)+aincr
13105           enddo
13106           call zerograd
13107           call etotal(energia1)
13108           etot1=energia1(0)
13109         ggg(j)=(etot1-etot)/aincr
13110         dc(j,i)=ddc(j)
13111         do k=i+1,nres
13112           c(j,k)=c(j,k)-aincr
13113           c(j,k+nres)=c(j,k+nres)-aincr
13114           enddo
13115         enddo
13116       do j=1,3
13117         c(j,i+nres)=c(j,i+nres)+aincr
13118         dc(j,i+nres)=dc(j,i+nres)+aincr
13119           call zerograd
13120           call etotal(energia1)
13121           etot1=energia1(0)
13122         ggg(j+3)=(etot1-etot)/aincr
13123         c(j,i+nres)=xx(j)
13124         dc(j,i+nres)=ddx(j)
13125         enddo
13126       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
13127          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
13128       enddo
13129       return
13130       end subroutine check_ecart
13131 #ifdef CARGRAD
13132 !-----------------------------------------------------------------------------
13133       subroutine check_ecartint
13134 ! Check the gradient of the energy in Cartesian coordinates.
13135       use io_base, only: intout
13136       use MD_data, only: iset
13137 !      implicit real*8 (a-h,o-z)
13138 !      include 'DIMENSIONS'
13139 !      include 'COMMON.CONTROL'
13140 !      include 'COMMON.CHAIN'
13141 !      include 'COMMON.DERIV'
13142 !      include 'COMMON.IOUNITS'
13143 !      include 'COMMON.VAR'
13144 !      include 'COMMON.CONTACTS'
13145 !      include 'COMMON.MD'
13146 !      include 'COMMON.LOCAL'
13147 !      include 'COMMON.SPLITELE'
13148       use comm_srutu
13149 !el      integer :: icall
13150 !el      common /srutu/ icall
13151       real(kind=8),dimension(6) :: ggg,ggg1
13152       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
13153       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
13154       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
13155       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
13156       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
13157       real(kind=8),dimension(0:n_ene) :: energia,energia1
13158       integer :: uiparm(1)
13159       real(kind=8) :: urparm(1)
13160 !EL      external fdum
13161       integer :: i,j,k,nf
13162       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
13163                    etot21,etot22
13164       r_cut=2.0d0
13165       rlambd=0.3d0
13166       icg=1
13167       nf=0
13168       nfl=0
13169       if (iset.eq.0) iset=1
13170       call intout
13171 !      call intcartderiv
13172 !      call checkintcartgrad
13173       call zerograd
13174       aincr=1.0D-5
13175       write(iout,*) 'Calling CHECK_ECARTINT.'
13176       nf=0
13177       icall=0
13178       call geom_to_var(nvar,x)
13179       write (iout,*) "split_ene ",split_ene
13180       call flush(iout)
13181       if (.not.split_ene) then
13182         call zerograd
13183         call etotal(energia)
13184         etot=energia(0)
13185         call cartgrad
13186         icall =1
13187         do i=1,nres
13188           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
13189         enddo
13190         do j=1,3
13191           grad_s(j,0)=gcart(j,0)
13192         enddo
13193         do i=1,nres
13194           do j=1,3
13195             grad_s(j,i)=gcart(j,i)
13196             grad_s(j+3,i)=gxcart(j,i)
13197           enddo
13198         enddo
13199       else
13200 !- split gradient check
13201         call zerograd
13202         call etotal_long(energia)
13203 !el        call enerprint(energia)
13204         call cartgrad
13205         icall =1
13206         do i=1,nres
13207           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13208           (gxcart(j,i),j=1,3)
13209         enddo
13210         do j=1,3
13211           grad_s(j,0)=gcart(j,0)
13212         enddo
13213         do i=1,nres
13214           do j=1,3
13215             grad_s(j,i)=gcart(j,i)
13216             grad_s(j+3,i)=gxcart(j,i)
13217           enddo
13218         enddo
13219         call zerograd
13220         call etotal_short(energia)
13221         call enerprint(energia)
13222         call cartgrad
13223         icall =1
13224         do i=1,nres
13225           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13226           (gxcart(j,i),j=1,3)
13227         enddo
13228         do j=1,3
13229           grad_s1(j,0)=gcart(j,0)
13230         enddo
13231         do i=1,nres
13232           do j=1,3
13233             grad_s1(j,i)=gcart(j,i)
13234             grad_s1(j+3,i)=gxcart(j,i)
13235           enddo
13236         enddo
13237       endif
13238       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
13239 !      do i=1,nres
13240       do i=nnt,nct
13241         do j=1,3
13242           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
13243           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
13244         ddc(j)=c(j,i)
13245         ddx(j)=c(j,i+nres)
13246           dcnorm_safe1(j)=dc_norm(j,i-1)
13247           dcnorm_safe2(j)=dc_norm(j,i)
13248           dxnorm_safe(j)=dc_norm(j,i+nres)
13249         enddo
13250       do j=1,3
13251         c(j,i)=ddc(j)+aincr
13252           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
13253           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
13254           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
13255           dc(j,i)=c(j,i+1)-c(j,i)
13256           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13257           call int_from_cart1(.false.)
13258           if (.not.split_ene) then
13259            call zerograd
13260             call etotal(energia1)
13261             etot1=energia1(0)
13262             write (iout,*) "ij",i,j," etot1",etot1
13263           else
13264 !- split gradient
13265             call etotal_long(energia1)
13266             etot11=energia1(0)
13267             call etotal_short(energia1)
13268             etot12=energia1(0)
13269           endif
13270 !- end split gradient
13271 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
13272         c(j,i)=ddc(j)-aincr
13273           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
13274           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
13275           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
13276           dc(j,i)=c(j,i+1)-c(j,i)
13277           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13278           call int_from_cart1(.false.)
13279           if (.not.split_ene) then
13280             call zerograd
13281             call etotal(energia1)
13282             etot2=energia1(0)
13283             write (iout,*) "ij",i,j," etot2",etot2
13284           ggg(j)=(etot1-etot2)/(2*aincr)
13285           else
13286 !- split gradient
13287             call etotal_long(energia1)
13288             etot21=energia1(0)
13289           ggg(j)=(etot11-etot21)/(2*aincr)
13290             call etotal_short(energia1)
13291             etot22=energia1(0)
13292           ggg1(j)=(etot12-etot22)/(2*aincr)
13293 !- end split gradient
13294 !            write (iout,*) "etot21",etot21," etot22",etot22
13295           endif
13296 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13297         c(j,i)=ddc(j)
13298           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
13299           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
13300           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
13301           dc(j,i)=c(j,i+1)-c(j,i)
13302           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13303           dc_norm(j,i-1)=dcnorm_safe1(j)
13304           dc_norm(j,i)=dcnorm_safe2(j)
13305           dc_norm(j,i+nres)=dxnorm_safe(j)
13306         enddo
13307       do j=1,3
13308         c(j,i+nres)=ddx(j)+aincr
13309           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13310           call int_from_cart1(.false.)
13311           if (.not.split_ene) then
13312             call zerograd
13313             call etotal(energia1)
13314             etot1=energia1(0)
13315           else
13316 !- split gradient
13317             call etotal_long(energia1)
13318             etot11=energia1(0)
13319             call etotal_short(energia1)
13320             etot12=energia1(0)
13321           endif
13322 !- end split gradient
13323         c(j,i+nres)=ddx(j)-aincr
13324           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13325           call int_from_cart1(.false.)
13326           if (.not.split_ene) then
13327            call zerograd
13328            call etotal(energia1)
13329             etot2=energia1(0)
13330           ggg(j+3)=(etot1-etot2)/(2*aincr)
13331           else
13332 !- split gradient
13333             call etotal_long(energia1)
13334             etot21=energia1(0)
13335           ggg(j+3)=(etot11-etot21)/(2*aincr)
13336             call etotal_short(energia1)
13337             etot22=energia1(0)
13338           ggg1(j+3)=(etot12-etot22)/(2*aincr)
13339 !- end split gradient
13340           endif
13341 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13342         c(j,i+nres)=ddx(j)
13343           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13344           dc_norm(j,i+nres)=dxnorm_safe(j)
13345           call int_from_cart1(.false.)
13346         enddo
13347       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13348          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
13349         if (split_ene) then
13350           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13351          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
13352          k=1,6)
13353          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13354          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
13355          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
13356         endif
13357       enddo
13358       return
13359       end subroutine check_ecartint
13360 #else
13361 !-----------------------------------------------------------------------------
13362       subroutine check_ecartint
13363 ! Check the gradient of the energy in Cartesian coordinates.
13364       use io_base, only: intout
13365       use MD_data, only: iset
13366 !      implicit real*8 (a-h,o-z)
13367 !      include 'DIMENSIONS'
13368 !      include 'COMMON.CONTROL'
13369 !      include 'COMMON.CHAIN'
13370 !      include 'COMMON.DERIV'
13371 !      include 'COMMON.IOUNITS'
13372 !      include 'COMMON.VAR'
13373 !      include 'COMMON.CONTACTS'
13374 !      include 'COMMON.MD'
13375 !      include 'COMMON.LOCAL'
13376 !      include 'COMMON.SPLITELE'
13377       use comm_srutu
13378 !el      integer :: icall
13379 !el      common /srutu/ icall
13380       real(kind=8),dimension(6) :: ggg,ggg1
13381       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
13382       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
13383       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
13384       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
13385       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
13386       real(kind=8),dimension(0:n_ene) :: energia,energia1
13387       integer :: uiparm(1)
13388       real(kind=8) :: urparm(1)
13389 !EL      external fdum
13390       integer :: i,j,k,nf
13391       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
13392                    etot21,etot22
13393       r_cut=2.0d0
13394       rlambd=0.3d0
13395       icg=1
13396       nf=0
13397       nfl=0
13398       if (iset.eq.0) iset=1
13399       call intout
13400 !      call intcartderiv
13401 !      call checkintcartgrad
13402       call zerograd
13403       aincr=1.0D-6
13404       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
13405       nf=0
13406       icall=0
13407       call geom_to_var(nvar,x)
13408       if (.not.split_ene) then
13409         call etotal(energia)
13410         etot=energia(0)
13411 !el        call enerprint(energia)
13412         call cartgrad
13413         icall =1
13414         do i=1,nres
13415           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
13416         enddo
13417         do j=1,3
13418           grad_s(j,0)=gcart(j,0)
13419           grad_s(j+3,0)=gxcart(j,0)
13420         enddo
13421         do i=1,nres
13422           do j=1,3
13423             grad_s(j,i)=gcart(j,i)
13424 !              if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
13425
13426 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
13427             grad_s(j+3,i)=gxcart(j,i)
13428           enddo
13429         enddo
13430       else
13431 !- split gradient check
13432         call zerograd
13433         call etotal_long(energia)
13434 !el        call enerprint(energia)
13435         call cartgrad
13436         icall =1
13437         do i=1,nres
13438           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13439           (gxcart(j,i),j=1,3)
13440         enddo
13441         do j=1,3
13442           grad_s(j,0)=gcart(j,0)
13443         enddo
13444         do i=1,nres
13445           do j=1,3
13446             grad_s(j,i)=gcart(j,i)
13447 !            if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
13448             grad_s(j+3,i)=gxcart(j,i)
13449           enddo
13450         enddo
13451         call zerograd
13452         call etotal_short(energia)
13453 !el        call enerprint(energia)
13454         call cartgrad
13455         icall =1
13456         do i=1,nres
13457           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13458           (gxcart(j,i),j=1,3)
13459         enddo
13460         do j=1,3
13461           grad_s1(j,0)=gcart(j,0)
13462         enddo
13463         do i=1,nres
13464           do j=1,3
13465             grad_s1(j,i)=gcart(j,i)
13466             grad_s1(j+3,i)=gxcart(j,i)
13467           enddo
13468         enddo
13469       endif
13470       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
13471       do i=0,nres
13472         do j=1,3
13473         xx(j)=c(j,i+nres)
13474         ddc(j)=dc(j,i)
13475         ddx(j)=dc(j,i+nres)
13476           do k=1,3
13477             dcnorm_safe(k)=dc_norm(k,i)
13478             dxnorm_safe(k)=dc_norm(k,i+nres)
13479           enddo
13480         enddo
13481       do j=1,3
13482         dc(j,i)=ddc(j)+aincr
13483           call chainbuild_cart
13484 #ifdef MPI
13485 ! Broadcast the order to compute internal coordinates to the slaves.
13486 !          if (nfgtasks.gt.1)
13487 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
13488 #endif
13489 !          call int_from_cart1(.false.)
13490           if (.not.split_ene) then
13491            call zerograd
13492             call etotal(energia1)
13493             etot1=energia1(0)
13494 !            call enerprint(energia1)
13495           else
13496 !- split gradient
13497             call etotal_long(energia1)
13498             etot11=energia1(0)
13499             call etotal_short(energia1)
13500             etot12=energia1(0)
13501 !            write (iout,*) "etot11",etot11," etot12",etot12
13502           endif
13503 !- end split gradient
13504 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
13505         dc(j,i)=ddc(j)-aincr
13506           call chainbuild_cart
13507 !          call int_from_cart1(.false.)
13508           if (.not.split_ene) then
13509                   call zerograd
13510             call etotal(energia1)
13511             etot2=energia1(0)
13512           ggg(j)=(etot1-etot2)/(2*aincr)
13513           else
13514 !- split gradient
13515             call etotal_long(energia1)
13516             etot21=energia1(0)
13517           ggg(j)=(etot11-etot21)/(2*aincr)
13518             call etotal_short(energia1)
13519             etot22=energia1(0)
13520           ggg1(j)=(etot12-etot22)/(2*aincr)
13521 !- end split gradient
13522 !            write (iout,*) "etot21",etot21," etot22",etot22
13523           endif
13524 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13525         dc(j,i)=ddc(j)
13526           call chainbuild_cart
13527         enddo
13528       do j=1,3
13529         dc(j,i+nres)=ddx(j)+aincr
13530           call chainbuild_cart
13531 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
13532 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
13533 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
13534 !          write (iout,*) "dxnormnorm",dsqrt(
13535 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
13536 !          write (iout,*) "dxnormnormsafe",dsqrt(
13537 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
13538 !          write (iout,*)
13539           if (.not.split_ene) then
13540             call zerograd
13541             call etotal(energia1)
13542             etot1=energia1(0)
13543           else
13544 !- split gradient
13545             call etotal_long(energia1)
13546             etot11=energia1(0)
13547             call etotal_short(energia1)
13548             etot12=energia1(0)
13549           endif
13550 !- end split gradient
13551 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
13552         dc(j,i+nres)=ddx(j)-aincr
13553           call chainbuild_cart
13554 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
13555 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
13556 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
13557 !          write (iout,*)
13558 !          write (iout,*) "dxnormnorm",dsqrt(
13559 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
13560 !          write (iout,*) "dxnormnormsafe",dsqrt(
13561 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
13562           if (.not.split_ene) then
13563             call zerograd
13564             call etotal(energia1)
13565             etot2=energia1(0)
13566           ggg(j+3)=(etot1-etot2)/(2*aincr)
13567           else
13568 !- split gradient
13569             call etotal_long(energia1)
13570             etot21=energia1(0)
13571           ggg(j+3)=(etot11-etot21)/(2*aincr)
13572             call etotal_short(energia1)
13573             etot22=energia1(0)
13574           ggg1(j+3)=(etot12-etot22)/(2*aincr)
13575 !- end split gradient
13576           endif
13577 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13578         dc(j,i+nres)=ddx(j)
13579           call chainbuild_cart
13580         enddo
13581       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13582          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
13583         if (split_ene) then
13584           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13585          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
13586          k=1,6)
13587          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13588          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
13589          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
13590         endif
13591       enddo
13592       return
13593       end subroutine check_ecartint
13594 #endif
13595 !-----------------------------------------------------------------------------
13596       subroutine check_eint
13597 ! Check the gradient of energy in internal coordinates.
13598 !      implicit real*8 (a-h,o-z)
13599 !      include 'DIMENSIONS'
13600 !      include 'COMMON.CHAIN'
13601 !      include 'COMMON.DERIV'
13602 !      include 'COMMON.IOUNITS'
13603 !      include 'COMMON.VAR'
13604 !      include 'COMMON.GEO'
13605       use comm_srutu
13606 !el      integer :: icall
13607 !el      common /srutu/ icall
13608       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
13609       integer :: uiparm(1)
13610       real(kind=8) :: urparm(1)
13611       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
13612       character(len=6) :: key
13613 !EL      external fdum
13614       integer :: i,ii,nf
13615       real(kind=8) :: xi,aincr,etot,etot1,etot2
13616       call zerograd
13617       aincr=1.0D-7
13618       print '(a)','Calling CHECK_INT.'
13619       nf=0
13620       nfl=0
13621       icg=1
13622       call geom_to_var(nvar,x)
13623       call var_to_geom(nvar,x)
13624       call chainbuild
13625       icall=1
13626 !      print *,'ICG=',ICG
13627       call etotal(energia)
13628       etot = energia(0)
13629 !el      call enerprint(energia)
13630 !      print *,'ICG=',ICG
13631 #ifdef MPL
13632       if (MyID.ne.BossID) then
13633         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
13634         nf=x(nvar+1)
13635         nfl=x(nvar+2)
13636         icg=x(nvar+3)
13637       endif
13638 #endif
13639       nf=1
13640       nfl=3
13641 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
13642       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
13643 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
13644       icall=1
13645       do i=1,nvar
13646         xi=x(i)
13647         x(i)=xi-0.5D0*aincr
13648         call var_to_geom(nvar,x)
13649         call chainbuild
13650         call etotal(energia1)
13651         etot1=energia1(0)
13652         x(i)=xi+0.5D0*aincr
13653         call var_to_geom(nvar,x)
13654         call chainbuild
13655         call etotal(energia2)
13656         etot2=energia2(0)
13657         gg(i)=(etot2-etot1)/aincr
13658         write (iout,*) i,etot1,etot2
13659         x(i)=xi
13660       enddo
13661       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
13662           '     RelDiff*100% '
13663       do i=1,nvar
13664         if (i.le.nphi) then
13665           ii=i
13666           key = ' phi'
13667         else if (i.le.nphi+ntheta) then
13668           ii=i-nphi
13669           key=' theta'
13670         else if (i.le.nphi+ntheta+nside) then
13671            ii=i-(nphi+ntheta)
13672            key=' alpha'
13673         else
13674            ii=i-(nphi+ntheta+nside)
13675            key=' omega'
13676         endif
13677         write (iout,'(i3,a,i3,3(1pd16.6))') &
13678        i,key,ii,gg(i),gana(i),&
13679        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
13680       enddo
13681       return
13682       end subroutine check_eint
13683 !-----------------------------------------------------------------------------
13684 ! econstr_local.F
13685 !-----------------------------------------------------------------------------
13686       subroutine Econstr_back
13687 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
13688 !      implicit real*8 (a-h,o-z)
13689 !      include 'DIMENSIONS'
13690 !      include 'COMMON.CONTROL'
13691 !      include 'COMMON.VAR'
13692 !      include 'COMMON.MD'
13693       use MD_data
13694 !#ifndef LANG0
13695 !      include 'COMMON.LANGEVIN'
13696 !#else
13697 !      include 'COMMON.LANGEVIN.lang0'
13698 !#endif
13699 !      include 'COMMON.CHAIN'
13700 !      include 'COMMON.DERIV'
13701 !      include 'COMMON.GEO'
13702 !      include 'COMMON.LOCAL'
13703 !      include 'COMMON.INTERACT'
13704 !      include 'COMMON.IOUNITS'
13705 !      include 'COMMON.NAMES'
13706 !      include 'COMMON.TIME1'
13707       integer :: i,j,ii,k
13708       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
13709
13710       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
13711       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
13712       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
13713
13714       Uconst_back=0.0d0
13715       do i=1,nres
13716         dutheta(i)=0.0d0
13717         dugamma(i)=0.0d0
13718         do j=1,3
13719           duscdiff(j,i)=0.0d0
13720           duscdiffx(j,i)=0.0d0
13721         enddo
13722       enddo
13723       do i=1,nfrag_back
13724         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
13725 !
13726 ! Deviations from theta angles
13727 !
13728         utheta_i=0.0d0
13729         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
13730           dtheta_i=theta(j)-thetaref(j)
13731           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
13732           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
13733         enddo
13734         utheta(i)=utheta_i/(ii-1)
13735 !
13736 ! Deviations from gamma angles
13737 !
13738         ugamma_i=0.0d0
13739         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
13740           dgamma_i=pinorm(phi(j)-phiref(j))
13741 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
13742           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
13743           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
13744 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
13745         enddo
13746         ugamma(i)=ugamma_i/(ii-2)
13747 !
13748 ! Deviations from local SC geometry
13749 !
13750         uscdiff(i)=0.0d0
13751         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
13752           dxx=xxtab(j)-xxref(j)
13753           dyy=yytab(j)-yyref(j)
13754           dzz=zztab(j)-zzref(j)
13755           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
13756           do k=1,3
13757             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
13758              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
13759              (ii-1)
13760             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
13761              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
13762              (ii-1)
13763             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
13764            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
13765             /(ii-1)
13766           enddo
13767 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
13768 !     &      xxref(j),yyref(j),zzref(j)
13769         enddo
13770         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
13771 !        write (iout,*) i," uscdiff",uscdiff(i)
13772 !
13773 ! Put together deviations from local geometry
13774 !
13775         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
13776           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
13777 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
13778 !     &   " uconst_back",uconst_back
13779         utheta(i)=dsqrt(utheta(i))
13780         ugamma(i)=dsqrt(ugamma(i))
13781         uscdiff(i)=dsqrt(uscdiff(i))
13782       enddo
13783       return
13784       end subroutine Econstr_back
13785 !-----------------------------------------------------------------------------
13786 ! energy_p_new-sep_barrier.F
13787 !-----------------------------------------------------------------------------
13788       real(kind=8) function sscale(r)
13789 !      include "COMMON.SPLITELE"
13790       real(kind=8) :: r,gamm
13791       if(r.lt.r_cut-rlamb) then
13792         sscale=1.0d0
13793       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13794         gamm=(r-(r_cut-rlamb))/rlamb
13795         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13796       else
13797         sscale=0d0
13798       endif
13799       return
13800       end function sscale
13801       real(kind=8) function sscale_grad(r)
13802 !      include "COMMON.SPLITELE"
13803       real(kind=8) :: r,gamm
13804       if(r.lt.r_cut-rlamb) then
13805         sscale_grad=0.0d0
13806       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13807         gamm=(r-(r_cut-rlamb))/rlamb
13808         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
13809       else
13810         sscale_grad=0d0
13811       endif
13812       return
13813       end function sscale_grad
13814
13815 !!!!!!!!!! PBCSCALE
13816       real(kind=8) function sscale_ele(r)
13817 !      include "COMMON.SPLITELE"
13818       real(kind=8) :: r,gamm
13819       if(r.lt.r_cut_ele-rlamb_ele) then
13820         sscale_ele=1.0d0
13821       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13822         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13823         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13824       else
13825         sscale_ele=0d0
13826       endif
13827       return
13828       end function sscale_ele
13829
13830       real(kind=8)  function sscagrad_ele(r)
13831       real(kind=8) :: r,gamm
13832 !      include "COMMON.SPLITELE"
13833       if(r.lt.r_cut_ele-rlamb_ele) then
13834         sscagrad_ele=0.0d0
13835       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13836         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13837         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
13838       else
13839         sscagrad_ele=0.0d0
13840       endif
13841       return
13842       end function sscagrad_ele
13843       real(kind=8) function sscalelip(r)
13844       real(kind=8) r,gamm
13845         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
13846       return
13847       end function sscalelip
13848 !C-----------------------------------------------------------------------
13849       real(kind=8) function sscagradlip(r)
13850       real(kind=8) r,gamm
13851         sscagradlip=r*(6.0d0*r-6.0d0)
13852       return
13853       end function sscagradlip
13854
13855 !!!!!!!!!!!!!!!
13856 !-----------------------------------------------------------------------------
13857       subroutine elj_long(evdw)
13858 !
13859 ! This subroutine calculates the interaction energy of nonbonded side chains
13860 ! assuming the LJ potential of interaction.
13861 !
13862 !      implicit real*8 (a-h,o-z)
13863 !      include 'DIMENSIONS'
13864 !      include 'COMMON.GEO'
13865 !      include 'COMMON.VAR'
13866 !      include 'COMMON.LOCAL'
13867 !      include 'COMMON.CHAIN'
13868 !      include 'COMMON.DERIV'
13869 !      include 'COMMON.INTERACT'
13870 !      include 'COMMON.TORSION'
13871 !      include 'COMMON.SBRIDGE'
13872 !      include 'COMMON.NAMES'
13873 !      include 'COMMON.IOUNITS'
13874 !      include 'COMMON.CONTACTS'
13875       real(kind=8),parameter :: accur=1.0d-10
13876       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13877 !el local variables
13878       integer :: i,iint,j,k,itypi,itypi1,itypj
13879       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13880       real(kind=8) :: e1,e2,evdwij,evdw,sslipi,ssgradlipi,&
13881                       sslipj,ssgradlipj,aa,bb
13882 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13883       evdw=0.0D0
13884       do i=iatsc_s,iatsc_e
13885         itypi=itype(i,1)
13886         if (itypi.eq.ntyp1) cycle
13887         itypi1=itype(i+1,1)
13888         xi=c(1,nres+i)
13889         yi=c(2,nres+i)
13890         zi=c(3,nres+i)
13891         call to_box(xi,yi,zi)
13892         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13893 !
13894 ! Calculate SC interaction energy.
13895 !
13896         do iint=1,nint_gr(i)
13897 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13898 !d   &                  'iend=',iend(i,iint)
13899           do j=istart(i,iint),iend(i,iint)
13900             itypj=itype(j,1)
13901             if (itypj.eq.ntyp1) cycle
13902             xj=c(1,nres+j)-xi
13903             yj=c(2,nres+j)-yi
13904             zj=c(3,nres+j)-zi
13905             call to_box(xj,yj,zj)
13906             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13907             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13908              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13909             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13910              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13911             xj=boxshift(xj-xi,boxxsize)
13912             yj=boxshift(yj-yi,boxysize)
13913             zj=boxshift(zj-zi,boxzsize)
13914             rij=xj*xj+yj*yj+zj*zj
13915             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13916             if (sss.lt.1.0d0) then
13917               rrij=1.0D0/rij
13918               eps0ij=eps(itypi,itypj)
13919               fac=rrij**expon2
13920               e1=fac*fac*aa_aq(itypi,itypj)
13921               e2=fac*bb_aq(itypi,itypj)
13922               evdwij=e1+e2
13923               evdw=evdw+(1.0d0-sss)*evdwij
13924 !
13925 ! Calculate the components of the gradient in DC and X
13926 !
13927               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
13928               gg(1)=xj*fac
13929               gg(2)=yj*fac
13930               gg(3)=zj*fac
13931               do k=1,3
13932                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13933                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13934                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13935                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13936               enddo
13937             endif
13938           enddo      ! j
13939         enddo        ! iint
13940       enddo          ! i
13941       do i=1,nct
13942         do j=1,3
13943           gvdwc(j,i)=expon*gvdwc(j,i)
13944           gvdwx(j,i)=expon*gvdwx(j,i)
13945         enddo
13946       enddo
13947 !******************************************************************************
13948 !
13949 !                              N O T E !!!
13950 !
13951 ! To save time, the factor of EXPON has been extracted from ALL components
13952 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13953 ! use!
13954 !
13955 !******************************************************************************
13956       return
13957       end subroutine elj_long
13958 !-----------------------------------------------------------------------------
13959       subroutine elj_short(evdw)
13960 !
13961 ! This subroutine calculates the interaction energy of nonbonded side chains
13962 ! assuming the LJ potential of interaction.
13963 !
13964 !      implicit real*8 (a-h,o-z)
13965 !      include 'DIMENSIONS'
13966 !      include 'COMMON.GEO'
13967 !      include 'COMMON.VAR'
13968 !      include 'COMMON.LOCAL'
13969 !      include 'COMMON.CHAIN'
13970 !      include 'COMMON.DERIV'
13971 !      include 'COMMON.INTERACT'
13972 !      include 'COMMON.TORSION'
13973 !      include 'COMMON.SBRIDGE'
13974 !      include 'COMMON.NAMES'
13975 !      include 'COMMON.IOUNITS'
13976 !      include 'COMMON.CONTACTS'
13977       real(kind=8),parameter :: accur=1.0d-10
13978       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13979 !el local variables
13980       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
13981       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13982       real(kind=8) :: e1,e2,evdwij,evdw,sslipi,ssgradlipi,&
13983                       sslipj,ssgradlipj
13984 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13985       evdw=0.0D0
13986       do i=iatsc_s,iatsc_e
13987         itypi=itype(i,1)
13988         if (itypi.eq.ntyp1) cycle
13989         itypi1=itype(i+1,1)
13990         xi=c(1,nres+i)
13991         yi=c(2,nres+i)
13992         zi=c(3,nres+i)
13993         call to_box(xi,yi,zi)
13994         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13995 ! Change 12/1/95
13996         num_conti=0
13997 !
13998 ! Calculate SC interaction energy.
13999 !
14000         do iint=1,nint_gr(i)
14001 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
14002 !d   &                  'iend=',iend(i,iint)
14003           do j=istart(i,iint),iend(i,iint)
14004             itypj=itype(j,1)
14005             if (itypj.eq.ntyp1) cycle
14006             xj=c(1,nres+j)-xi
14007             yj=c(2,nres+j)-yi
14008             zj=c(3,nres+j)-zi
14009 ! Change 12/1/95 to calculate four-body interactions
14010             rij=xj*xj+yj*yj+zj*zj
14011             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
14012             if (sss.gt.0.0d0) then
14013               rrij=1.0D0/rij
14014               eps0ij=eps(itypi,itypj)
14015               fac=rrij**expon2
14016               e1=fac*fac*aa_aq(itypi,itypj)
14017               e2=fac*bb_aq(itypi,itypj)
14018               evdwij=e1+e2
14019               evdw=evdw+sss*evdwij
14020 !
14021 ! Calculate the components of the gradient in DC and X
14022 !
14023               fac=-rrij*(e1+evdwij)*sss
14024               gg(1)=xj*fac
14025               gg(2)=yj*fac
14026               gg(3)=zj*fac
14027               do k=1,3
14028                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
14029                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
14030                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
14031                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
14032               enddo
14033             endif
14034           enddo      ! j
14035         enddo        ! iint
14036       enddo          ! i
14037       do i=1,nct
14038         do j=1,3
14039           gvdwc(j,i)=expon*gvdwc(j,i)
14040           gvdwx(j,i)=expon*gvdwx(j,i)
14041         enddo
14042       enddo
14043 !******************************************************************************
14044 !
14045 !                              N O T E !!!
14046 !
14047 ! To save time, the factor of EXPON has been extracted from ALL components
14048 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
14049 ! use!
14050 !
14051 !******************************************************************************
14052       return
14053       end subroutine elj_short
14054 !-----------------------------------------------------------------------------
14055       subroutine eljk_long(evdw)
14056 !
14057 ! This subroutine calculates the interaction energy of nonbonded side chains
14058 ! assuming the LJK potential of interaction.
14059 !
14060 !      implicit real*8 (a-h,o-z)
14061 !      include 'DIMENSIONS'
14062 !      include 'COMMON.GEO'
14063 !      include 'COMMON.VAR'
14064 !      include 'COMMON.LOCAL'
14065 !      include 'COMMON.CHAIN'
14066 !      include 'COMMON.DERIV'
14067 !      include 'COMMON.INTERACT'
14068 !      include 'COMMON.IOUNITS'
14069 !      include 'COMMON.NAMES'
14070       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
14071       logical :: scheck
14072 !el local variables
14073       integer :: i,iint,j,k,itypi,itypi1,itypj
14074       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
14075                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
14076 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
14077       evdw=0.0D0
14078       do i=iatsc_s,iatsc_e
14079         itypi=itype(i,1)
14080         if (itypi.eq.ntyp1) cycle
14081         itypi1=itype(i+1,1)
14082         xi=c(1,nres+i)
14083         yi=c(2,nres+i)
14084         zi=c(3,nres+i)
14085           call to_box(xi,yi,zi)
14086
14087 !
14088 ! Calculate SC interaction energy.
14089 !
14090         do iint=1,nint_gr(i)
14091           do j=istart(i,iint),iend(i,iint)
14092             itypj=itype(j,1)
14093             if (itypj.eq.ntyp1) cycle
14094             xj=c(1,nres+j)-xi
14095             yj=c(2,nres+j)-yi
14096             zj=c(3,nres+j)-zi
14097           call to_box(xj,yj,zj)
14098             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14099             fac_augm=rrij**expon
14100             e_augm=augm(itypi,itypj)*fac_augm
14101             r_inv_ij=dsqrt(rrij)
14102             rij=1.0D0/r_inv_ij
14103             sss=sscale(rij/sigma(itypi,itypj))
14104             if (sss.lt.1.0d0) then
14105               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
14106               fac=r_shift_inv**expon
14107               e1=fac*fac*aa_aq(itypi,itypj)
14108               e2=fac*bb_aq(itypi,itypj)
14109               evdwij=e_augm+e1+e2
14110 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
14111 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
14112 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
14113 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
14114 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
14115 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
14116 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
14117               evdw=evdw+(1.0d0-sss)*evdwij
14118 !
14119 ! Calculate the components of the gradient in DC and X
14120 !
14121               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
14122               fac=fac*(1.0d0-sss)
14123               gg(1)=xj*fac
14124               gg(2)=yj*fac
14125               gg(3)=zj*fac
14126               do k=1,3
14127                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
14128                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
14129                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
14130                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
14131               enddo
14132             endif
14133           enddo      ! j
14134         enddo        ! iint
14135       enddo          ! i
14136       do i=1,nct
14137         do j=1,3
14138           gvdwc(j,i)=expon*gvdwc(j,i)
14139           gvdwx(j,i)=expon*gvdwx(j,i)
14140         enddo
14141       enddo
14142       return
14143       end subroutine eljk_long
14144 !-----------------------------------------------------------------------------
14145       subroutine eljk_short(evdw)
14146 !
14147 ! This subroutine calculates the interaction energy of nonbonded side chains
14148 ! assuming the LJK potential of interaction.
14149 !
14150 !      implicit real*8 (a-h,o-z)
14151 !      include 'DIMENSIONS'
14152 !      include 'COMMON.GEO'
14153 !      include 'COMMON.VAR'
14154 !      include 'COMMON.LOCAL'
14155 !      include 'COMMON.CHAIN'
14156 !      include 'COMMON.DERIV'
14157 !      include 'COMMON.INTERACT'
14158 !      include 'COMMON.IOUNITS'
14159 !      include 'COMMON.NAMES'
14160       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
14161       logical :: scheck
14162 !el local variables
14163       integer :: i,iint,j,k,itypi,itypi1,itypj
14164       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
14165                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij,&
14166                    sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
14167 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
14168       evdw=0.0D0
14169       do i=iatsc_s,iatsc_e
14170         itypi=itype(i,1)
14171         if (itypi.eq.ntyp1) cycle
14172         itypi1=itype(i+1,1)
14173         xi=c(1,nres+i)
14174         yi=c(2,nres+i)
14175         zi=c(3,nres+i)
14176         call to_box(xi,yi,zi)
14177         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14178 !
14179 ! Calculate SC interaction energy.
14180 !
14181         do iint=1,nint_gr(i)
14182           do j=istart(i,iint),iend(i,iint)
14183             itypj=itype(j,1)
14184             if (itypj.eq.ntyp1) cycle
14185             xj=c(1,nres+j)-xi
14186             yj=c(2,nres+j)-yi
14187             zj=c(3,nres+j)-zi
14188             call to_box(xj,yj,zj)
14189             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14190             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14191              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14192             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14193              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14194             xj=boxshift(xj-xi,boxxsize)
14195             yj=boxshift(yj-yi,boxysize)
14196             zj=boxshift(zj-zi,boxzsize)
14197             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14198             fac_augm=rrij**expon
14199             e_augm=augm(itypi,itypj)*fac_augm
14200             r_inv_ij=dsqrt(rrij)
14201             rij=1.0D0/r_inv_ij
14202             sss=sscale(rij/sigma(itypi,itypj))
14203             if (sss.gt.0.0d0) then
14204               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
14205               fac=r_shift_inv**expon
14206               e1=fac*fac*aa_aq(itypi,itypj)
14207               e2=fac*bb_aq(itypi,itypj)
14208               evdwij=e_augm+e1+e2
14209 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
14210 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
14211 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
14212 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
14213 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
14214 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
14215 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
14216               evdw=evdw+sss*evdwij
14217 !
14218 ! Calculate the components of the gradient in DC and X
14219 !
14220               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
14221               fac=fac*sss
14222               gg(1)=xj*fac
14223               gg(2)=yj*fac
14224               gg(3)=zj*fac
14225               do k=1,3
14226                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
14227                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
14228                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
14229                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
14230               enddo
14231             endif
14232           enddo      ! j
14233         enddo        ! iint
14234       enddo          ! i
14235       do i=1,nct
14236         do j=1,3
14237           gvdwc(j,i)=expon*gvdwc(j,i)
14238           gvdwx(j,i)=expon*gvdwx(j,i)
14239         enddo
14240       enddo
14241       return
14242       end subroutine eljk_short
14243 !-----------------------------------------------------------------------------
14244        subroutine ebp_long(evdw)
14245 ! This subroutine calculates the interaction energy of nonbonded side chains
14246 ! assuming the Berne-Pechukas potential of interaction.
14247 !
14248        use calc_data
14249 !      implicit real*8 (a-h,o-z)
14250 !      include 'DIMENSIONS'
14251 !      include 'COMMON.GEO'
14252 !      include 'COMMON.VAR'
14253 !      include 'COMMON.LOCAL'
14254 !      include 'COMMON.CHAIN'
14255 !      include 'COMMON.DERIV'
14256 !      include 'COMMON.NAMES'
14257 !      include 'COMMON.INTERACT'
14258 !      include 'COMMON.IOUNITS'
14259 !      include 'COMMON.CALC'
14260        use comm_srutu
14261 !el      integer :: icall
14262 !el      common /srutu/ icall
14263 !     double precision rrsave(maxdim)
14264         logical :: lprn
14265 !el local variables
14266         integer :: iint,itypi,itypi1,itypj
14267         real(kind=8) :: rrij,xi,yi,zi,fac,sslipi,ssgradlipi,&
14268                         sslipj,ssgradlipj,aa,bb
14269         real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
14270         evdw=0.0D0
14271 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
14272         evdw=0.0D0
14273 !     if (icall.eq.0) then
14274 !       lprn=.true.
14275 !     else
14276       lprn=.false.
14277 !     endif
14278 !el      ind=0
14279       do i=iatsc_s,iatsc_e
14280       itypi=itype(i,1)
14281       if (itypi.eq.ntyp1) cycle
14282       itypi1=itype(i+1,1)
14283       xi=c(1,nres+i)
14284       yi=c(2,nres+i)
14285       zi=c(3,nres+i)
14286         call to_box(xi,yi,zi)
14287         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14288       dxi=dc_norm(1,nres+i)
14289       dyi=dc_norm(2,nres+i)
14290       dzi=dc_norm(3,nres+i)
14291 !        dsci_inv=dsc_inv(itypi)
14292       dsci_inv=vbld_inv(i+nres)
14293 !
14294 ! Calculate SC interaction energy.
14295 !
14296       do iint=1,nint_gr(i)
14297       do j=istart(i,iint),iend(i,iint)
14298 !el            ind=ind+1
14299       itypj=itype(j,1)
14300       if (itypj.eq.ntyp1) cycle
14301 !            dscj_inv=dsc_inv(itypj)
14302       dscj_inv=vbld_inv(j+nres)
14303 chi1=chi(itypi,itypj)
14304 chi2=chi(itypj,itypi)
14305 chi12=chi1*chi2
14306 chip1=chip(itypi)
14307       alf1=alp(itypi)
14308       alf2=alp(itypj)
14309       alf12=0.5D0*(alf1+alf2)
14310         xj=c(1,nres+j)-xi
14311         yj=c(2,nres+j)-yi
14312         zj=c(3,nres+j)-zi
14313             call to_box(xj,yj,zj)
14314             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14315             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14316              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14317             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14318              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14319             xj=boxshift(xj-xi,boxxsize)
14320             yj=boxshift(yj-yi,boxysize)
14321             zj=boxshift(zj-zi,boxzsize)
14322         dxj=dc_norm(1,nres+j)
14323         dyj=dc_norm(2,nres+j)
14324         dzj=dc_norm(3,nres+j)
14325         rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14326         rij=dsqrt(rrij)
14327       sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14328
14329         if (sss.lt.1.0d0) then
14330
14331         ! Calculate the angle-dependent terms of energy & contributions to derivatives.
14332         call sc_angular
14333         ! Calculate whole angle-dependent part of epsilon and contributions
14334         ! to its derivatives
14335         fac=(rrij*sigsq)**expon2
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         evdwij=evdwij*eps2rt*eps3rt
14342       evdw=evdw+evdwij*(1.0d0-sss)
14343         if (lprn) then
14344         sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14345       epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14346         !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
14347         !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14348         !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
14349         !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
14350         !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
14351         !d     &          evdwij
14352         endif
14353         ! Calculate gradient components.
14354         e1=e1*eps1*eps2rt**2*eps3rt**2
14355       fac=-expon*(e1+evdwij)
14356         sigder=fac/sigsq
14357         fac=rrij*fac
14358         ! Calculate radial part of the gradient
14359         gg(1)=xj*fac
14360         gg(2)=yj*fac
14361         gg(3)=zj*fac
14362         ! Calculate the angular part of the gradient and sum add the contributions
14363         ! to the appropriate components of the Cartesian gradient.
14364       call sc_grad_scale(1.0d0-sss)
14365         endif
14366         enddo      ! j
14367         enddo        ! iint
14368         enddo          ! i
14369         !     stop
14370         return
14371         end subroutine ebp_long
14372         !-----------------------------------------------------------------------------
14373       subroutine ebp_short(evdw)
14374         !
14375         ! This subroutine calculates the interaction energy of nonbonded side chains
14376         ! assuming the Berne-Pechukas 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 !     double precision rrsave(maxdim)
14394         logical :: lprn
14395         !el local variables
14396         integer :: iint,itypi,itypi1,itypj
14397         real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
14398         real(kind=8) :: sss,e1,e2,evdw,aa,bb, &
14399         sslipi,ssgradlipi,sslipj,ssgradlipj
14400         evdw=0.0D0
14401         !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
14402         evdw=0.0D0
14403         !     if (icall.eq.0) then
14404         !       lprn=.true.
14405         !     else
14406         lprn=.false.
14407         !     endif
14408         !el      ind=0
14409         do i=iatsc_s,iatsc_e
14410       itypi=itype(i,1)
14411         if (itypi.eq.ntyp1) cycle
14412         itypi1=itype(i+1,1)
14413         xi=c(1,nres+i)
14414         yi=c(2,nres+i)
14415         zi=c(3,nres+i)
14416         call to_box(xi,yi,zi)
14417       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14418
14419         dxi=dc_norm(1,nres+i)
14420         dyi=dc_norm(2,nres+i)
14421         dzi=dc_norm(3,nres+i)
14422         !        dsci_inv=dsc_inv(itypi)
14423       dsci_inv=vbld_inv(i+nres)
14424         !
14425         ! Calculate SC interaction energy.
14426         !
14427         do iint=1,nint_gr(i)
14428       do j=istart(i,iint),iend(i,iint)
14429         !el            ind=ind+1
14430       itypj=itype(j,1)
14431         if (itypj.eq.ntyp1) cycle
14432         !            dscj_inv=dsc_inv(itypj)
14433         dscj_inv=vbld_inv(j+nres)
14434         chi1=chi(itypi,itypj)
14435       chi2=chi(itypj,itypi)
14436         chi12=chi1*chi2
14437         chip1=chip(itypi)
14438       chip2=chip(itypj)
14439         chip12=chip1*chip2
14440         alf1=alp(itypi)
14441         alf2=alp(itypj)
14442       alf12=0.5D0*(alf1+alf2)
14443         xj=c(1,nres+j)-xi
14444         yj=c(2,nres+j)-yi
14445         zj=c(3,nres+j)-zi
14446         call to_box(xj,yj,zj)
14447       call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14448         aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14449         +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14450         bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14451              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14452             xj=boxshift(xj-xi,boxxsize)
14453             yj=boxshift(yj-yi,boxysize)
14454             zj=boxshift(zj-zi,boxzsize)
14455             dxj=dc_norm(1,nres+j)
14456             dyj=dc_norm(2,nres+j)
14457             dzj=dc_norm(3,nres+j)
14458             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14459             rij=dsqrt(rrij)
14460             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14461
14462             if (sss.gt.0.0d0) then
14463
14464 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
14465               call sc_angular
14466 ! Calculate whole angle-dependent part of epsilon and contributions
14467 ! to its derivatives
14468               fac=(rrij*sigsq)**expon2
14469               e1=fac*fac*aa_aq(itypi,itypj)
14470               e2=fac*bb_aq(itypi,itypj)
14471               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14472               eps2der=evdwij*eps3rt
14473               eps3der=evdwij*eps2rt
14474               evdwij=evdwij*eps2rt*eps3rt
14475               evdw=evdw+evdwij*sss
14476               if (lprn) then
14477               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14478               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14479 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
14480 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14481 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
14482 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
14483 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
14484 !d     &          evdwij
14485               endif
14486 ! Calculate gradient components.
14487               e1=e1*eps1*eps2rt**2*eps3rt**2
14488               fac=-expon*(e1+evdwij)
14489               sigder=fac/sigsq
14490               fac=rrij*fac
14491 ! Calculate radial part of the gradient
14492               gg(1)=xj*fac
14493               gg(2)=yj*fac
14494               gg(3)=zj*fac
14495 ! Calculate the angular part of the gradient and sum add the contributions
14496 ! to the appropriate components of the Cartesian gradient.
14497               call sc_grad_scale(sss)
14498             endif
14499           enddo      ! j
14500         enddo        ! iint
14501       enddo          ! i
14502 !     stop
14503       return
14504       end subroutine ebp_short
14505 !-----------------------------------------------------------------------------
14506       subroutine egb_long(evdw)
14507 !
14508 ! This subroutine calculates the interaction energy of nonbonded side chains
14509 ! assuming the Gay-Berne potential of interaction.
14510 !
14511       use calc_data
14512 !      implicit real*8 (a-h,o-z)
14513 !      include 'DIMENSIONS'
14514 !      include 'COMMON.GEO'
14515 !      include 'COMMON.VAR'
14516 !      include 'COMMON.LOCAL'
14517 !      include 'COMMON.CHAIN'
14518 !      include 'COMMON.DERIV'
14519 !      include 'COMMON.NAMES'
14520 !      include 'COMMON.INTERACT'
14521 !      include 'COMMON.IOUNITS'
14522 !      include 'COMMON.CALC'
14523 !      include 'COMMON.CONTROL'
14524       logical :: lprn
14525 !el local variables
14526       integer :: iint,itypi,itypi1,itypj,subchap
14527       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
14528       real(kind=8) :: sss,e1,e2,evdw,sss_grad
14529       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14530                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
14531                     ssgradlipi,ssgradlipj
14532
14533
14534       evdw=0.0D0
14535 !cccc      energy_dec=.false.
14536 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14537       evdw=0.0D0
14538       lprn=.false.
14539 !     if (icall.eq.0) lprn=.false.
14540 !el      ind=0
14541       do i=iatsc_s,iatsc_e
14542         itypi=itype(i,1)
14543         if (itypi.eq.ntyp1) cycle
14544         itypi1=itype(i+1,1)
14545         xi=c(1,nres+i)
14546         yi=c(2,nres+i)
14547         zi=c(3,nres+i)
14548         call to_box(xi,yi,zi)
14549         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14550         dxi=dc_norm(1,nres+i)
14551         dyi=dc_norm(2,nres+i)
14552         dzi=dc_norm(3,nres+i)
14553 !        dsci_inv=dsc_inv(itypi)
14554         dsci_inv=vbld_inv(i+nres)
14555 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
14556 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
14557 !
14558 ! Calculate SC interaction energy.
14559 !
14560         do iint=1,nint_gr(i)
14561           do j=istart(i,iint),iend(i,iint)
14562             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
14563 !              call dyn_ssbond_ene(i,j,evdwij)
14564 !              evdw=evdw+evdwij
14565 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14566 !                              'evdw',i,j,evdwij,' ss'
14567 !              if (energy_dec) write (iout,*) &
14568 !                              'evdw',i,j,evdwij,' ss'
14569 !             do k=j+1,iend(i,iint)
14570 !C search over all next residues
14571 !              if (dyn_ss_mask(k)) then
14572 !C check if they are cysteins
14573 !C              write(iout,*) 'k=',k
14574
14575 !c              write(iout,*) "PRZED TRI", evdwij
14576 !               evdwij_przed_tri=evdwij
14577 !              call triple_ssbond_ene(i,j,k,evdwij)
14578 !c               if(evdwij_przed_tri.ne.evdwij) then
14579 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
14580 !c               endif
14581
14582 !c              write(iout,*) "PO TRI", evdwij
14583 !C call the energy function that removes the artifical triple disulfide
14584 !C bond the soubroutine is located in ssMD.F
14585 !              evdw=evdw+evdwij
14586               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14587                             'evdw',i,j,evdwij,'tss'
14588 !              endif!dyn_ss_mask(k)
14589 !             enddo! k
14590
14591             ELSE
14592 !el            ind=ind+1
14593             itypj=itype(j,1)
14594             if (itypj.eq.ntyp1) cycle
14595 !            dscj_inv=dsc_inv(itypj)
14596             dscj_inv=vbld_inv(j+nres)
14597 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
14598 !     &       1.0d0/vbld(j+nres)
14599 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
14600             sig0ij=sigma(itypi,itypj)
14601             chi1=chi(itypi,itypj)
14602             chi2=chi(itypj,itypi)
14603             chi12=chi1*chi2
14604             chip1=chip(itypi)
14605             chip2=chip(itypj)
14606             chip12=chip1*chip2
14607             alf1=alp(itypi)
14608             alf2=alp(itypj)
14609             alf12=0.5D0*(alf1+alf2)
14610             xj=c(1,nres+j)
14611             yj=c(2,nres+j)
14612             zj=c(3,nres+j)
14613 ! Searching for nearest neighbour
14614             call to_box(xj,yj,zj)
14615             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14616             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14617              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14618             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14619              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14620             xj=boxshift(xj-xi,boxxsize)
14621             yj=boxshift(yj-yi,boxysize)
14622             zj=boxshift(zj-zi,boxzsize)
14623             dxj=dc_norm(1,nres+j)
14624             dyj=dc_norm(2,nres+j)
14625             dzj=dc_norm(3,nres+j)
14626             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14627             rij=dsqrt(rrij)
14628             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14629             sss_ele_cut=sscale_ele(1.0d0/(rij))
14630             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
14631             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14632             if (sss_ele_cut.le.0.0) cycle
14633             if (sss.lt.1.0d0) then
14634
14635 ! Calculate angle-dependent terms of energy and contributions to their
14636 ! derivatives.
14637               call sc_angular
14638               sigsq=1.0D0/sigsq
14639               sig=sig0ij*dsqrt(sigsq)
14640               rij_shift=1.0D0/rij-sig+sig0ij
14641 ! for diagnostics; uncomment
14642 !              rij_shift=1.2*sig0ij
14643 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14644               if (rij_shift.le.0.0D0) then
14645                 evdw=1.0D20
14646 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14647 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14648 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14649                 return
14650               endif
14651               sigder=-sig*sigsq
14652 !---------------------------------------------------------------
14653               rij_shift=1.0D0/rij_shift
14654               fac=rij_shift**expon
14655               e1=fac*fac*aa
14656               e2=fac*bb
14657               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14658               eps2der=evdwij*eps3rt
14659               eps3der=evdwij*eps2rt
14660 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14661 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14662               evdwij=evdwij*eps2rt*eps3rt
14663               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
14664               if (lprn) then
14665               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14666               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14667               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14668                 restyp(itypi,1),i,restyp(itypj,1),j,&
14669                 epsi,sigm,chi1,chi2,chip1,chip2,&
14670                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14671                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14672                 evdwij
14673               endif
14674
14675               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14676                               'evdw',i,j,evdwij
14677 !              if (energy_dec) write (iout,*) &
14678 !                              'evdw',i,j,evdwij,"egb_long"
14679
14680 ! Calculate gradient components.
14681               e1=e1*eps1*eps2rt**2*eps3rt**2
14682               fac=-expon*(e1+evdwij)*rij_shift
14683               sigder=fac*sigder
14684               fac=rij*fac
14685               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14686               *rij-sss_grad/(1.0-sss)*rij  &
14687             /sigmaii(itypi,itypj))
14688 !              fac=0.0d0
14689 ! Calculate the radial part of the gradient
14690               gg(1)=xj*fac
14691               gg(2)=yj*fac
14692               gg(3)=zj*fac
14693 ! Calculate angular part of the gradient.
14694               call sc_grad_scale(1.0d0-sss)
14695             ENDIF    !mask_dyn_ss
14696             endif
14697           enddo      ! j
14698         enddo        ! iint
14699       enddo          ! i
14700 !      write (iout,*) "Number of loop steps in EGB:",ind
14701 !ccc      energy_dec=.false.
14702       return
14703       end subroutine egb_long
14704 !-----------------------------------------------------------------------------
14705       subroutine egb_short(evdw)
14706 !
14707 ! This subroutine calculates the interaction energy of nonbonded side chains
14708 ! assuming the Gay-Berne potential of interaction.
14709 !
14710       use calc_data
14711 !      implicit real*8 (a-h,o-z)
14712 !      include 'DIMENSIONS'
14713 !      include 'COMMON.GEO'
14714 !      include 'COMMON.VAR'
14715 !      include 'COMMON.LOCAL'
14716 !      include 'COMMON.CHAIN'
14717 !      include 'COMMON.DERIV'
14718 !      include 'COMMON.NAMES'
14719 !      include 'COMMON.INTERACT'
14720 !      include 'COMMON.IOUNITS'
14721 !      include 'COMMON.CALC'
14722 !      include 'COMMON.CONTROL'
14723       logical :: lprn
14724 !el local variables
14725       integer :: iint,itypi,itypi1,itypj,subchap
14726       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
14727       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
14728       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14729                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
14730                     ssgradlipi,ssgradlipj
14731       evdw=0.0D0
14732 !cccc      energy_dec=.false.
14733 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14734       evdw=0.0D0
14735       lprn=.false.
14736 !     if (icall.eq.0) lprn=.false.
14737 !el      ind=0
14738       do i=iatsc_s,iatsc_e
14739         itypi=itype(i,1)
14740         if (itypi.eq.ntyp1) cycle
14741         itypi1=itype(i+1,1)
14742         xi=c(1,nres+i)
14743         yi=c(2,nres+i)
14744         zi=c(3,nres+i)
14745         call to_box(xi,yi,zi)
14746         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14747
14748         dxi=dc_norm(1,nres+i)
14749         dyi=dc_norm(2,nres+i)
14750         dzi=dc_norm(3,nres+i)
14751 !        dsci_inv=dsc_inv(itypi)
14752         dsci_inv=vbld_inv(i+nres)
14753
14754         dxi=dc_norm(1,nres+i)
14755         dyi=dc_norm(2,nres+i)
14756         dzi=dc_norm(3,nres+i)
14757 !        dsci_inv=dsc_inv(itypi)
14758         dsci_inv=vbld_inv(i+nres)
14759         do iint=1,nint_gr(i)
14760           do j=istart(i,iint),iend(i,iint)
14761             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
14762               call dyn_ssbond_ene(i,j,evdwij)
14763               evdw=evdw+evdwij
14764               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14765                               'evdw',i,j,evdwij,' ss'
14766              do k=j+1,iend(i,iint)
14767 !C search over all next residues
14768               if (dyn_ss_mask(k)) then
14769 !C check if they are cysteins
14770 !C              write(iout,*) 'k=',k
14771
14772 !c              write(iout,*) "PRZED TRI", evdwij
14773 !               evdwij_przed_tri=evdwij
14774               call triple_ssbond_ene(i,j,k,evdwij)
14775 !c               if(evdwij_przed_tri.ne.evdwij) then
14776 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
14777 !c               endif
14778
14779 !c              write(iout,*) "PO TRI", evdwij
14780 !C call the energy function that removes the artifical triple disulfide
14781 !C bond the soubroutine is located in ssMD.F
14782               evdw=evdw+evdwij
14783               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14784                             'evdw',i,j,evdwij,'tss'
14785               endif!dyn_ss_mask(k)
14786              enddo! k
14787             ELSE
14788
14789 !          typj=itype(j,1)
14790             if (itypj.eq.ntyp1) cycle
14791 !            dscj_inv=dsc_inv(itypj)
14792             dscj_inv=vbld_inv(j+nres)
14793             dscj_inv=dsc_inv(itypj)
14794 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
14795 !     &       1.0d0/vbld(j+nres)
14796 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
14797             sig0ij=sigma(itypi,itypj)
14798             chi1=chi(itypi,itypj)
14799             chi2=chi(itypj,itypi)
14800             chi12=chi1*chi2
14801             chip1=chip(itypi)
14802             chip2=chip(itypj)
14803             chip12=chip1*chip2
14804             alf1=alp(itypi)
14805             alf2=alp(itypj)
14806             alf12=0.5D0*(alf1+alf2)
14807 !            xj=c(1,nres+j)-xi
14808 !            yj=c(2,nres+j)-yi
14809 !            zj=c(3,nres+j)-zi
14810             xj=c(1,nres+j)
14811             yj=c(2,nres+j)
14812             zj=c(3,nres+j)
14813 ! Searching for nearest neighbour
14814             call to_box(xj,yj,zj)
14815             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14816             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14817              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14818             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14819              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14820             xj=boxshift(xj-xi,boxxsize)
14821             yj=boxshift(yj-yi,boxysize)
14822             zj=boxshift(zj-zi,boxzsize)
14823             dxj=dc_norm(1,nres+j)
14824             dyj=dc_norm(2,nres+j)
14825             dzj=dc_norm(3,nres+j)
14826             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14827             rij=dsqrt(rrij)
14828             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14829             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14830             sss_ele_cut=sscale_ele(1.0d0/(rij))
14831             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
14832             if (sss_ele_cut.le.0.0) cycle
14833
14834             if (sss.gt.0.0d0) then
14835
14836 ! Calculate angle-dependent terms of energy and contributions to their
14837 ! derivatives.
14838               call sc_angular
14839               sigsq=1.0D0/sigsq
14840               sig=sig0ij*dsqrt(sigsq)
14841               rij_shift=1.0D0/rij-sig+sig0ij
14842 ! for diagnostics; uncomment
14843 !              rij_shift=1.2*sig0ij
14844 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14845               if (rij_shift.le.0.0D0) then
14846                 evdw=1.0D20
14847 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14848 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14849 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14850                 return
14851               endif
14852               sigder=-sig*sigsq
14853 !---------------------------------------------------------------
14854               rij_shift=1.0D0/rij_shift
14855               fac=rij_shift**expon
14856               e1=fac*fac*aa
14857               e2=fac*bb
14858               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14859               eps2der=evdwij*eps3rt
14860               eps3der=evdwij*eps2rt
14861 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14862 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14863               evdwij=evdwij*eps2rt*eps3rt
14864               evdw=evdw+evdwij*sss*sss_ele_cut
14865               if (lprn) then
14866               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14867               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14868               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14869                 restyp(itypi,1),i,restyp(itypj,1),j,&
14870                 epsi,sigm,chi1,chi2,chip1,chip2,&
14871                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14872                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14873                 evdwij
14874               endif
14875
14876               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14877                               'evdw',i,j,evdwij
14878 !              if (energy_dec) write (iout,*) &
14879 !                              'evdw',i,j,evdwij,"egb_short"
14880
14881 ! Calculate gradient components.
14882               e1=e1*eps1*eps2rt**2*eps3rt**2
14883               fac=-expon*(e1+evdwij)*rij_shift
14884               sigder=fac*sigder
14885               fac=rij*fac
14886               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14887             *rij+sss_grad/sss*rij  &
14888             /sigmaii(itypi,itypj))
14889
14890 !              fac=0.0d0
14891 ! Calculate the radial part of the gradient
14892               gg(1)=xj*fac
14893               gg(2)=yj*fac
14894               gg(3)=zj*fac
14895 ! Calculate angular part of the gradient.
14896               call sc_grad_scale(sss)
14897             endif
14898           ENDIF !mask_dyn_ss
14899           enddo      ! j
14900         enddo        ! iint
14901       enddo          ! i
14902 !      write (iout,*) "Number of loop steps in EGB:",ind
14903 !ccc      energy_dec=.false.
14904       return
14905       end subroutine egb_short
14906 !-----------------------------------------------------------------------------
14907       subroutine egbv_long(evdw)
14908 !
14909 ! This subroutine calculates the interaction energy of nonbonded side chains
14910 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14911 !
14912       use calc_data
14913 !      implicit real*8 (a-h,o-z)
14914 !      include 'DIMENSIONS'
14915 !      include 'COMMON.GEO'
14916 !      include 'COMMON.VAR'
14917 !      include 'COMMON.LOCAL'
14918 !      include 'COMMON.CHAIN'
14919 !      include 'COMMON.DERIV'
14920 !      include 'COMMON.NAMES'
14921 !      include 'COMMON.INTERACT'
14922 !      include 'COMMON.IOUNITS'
14923 !      include 'COMMON.CALC'
14924       use comm_srutu
14925 !el      integer :: icall
14926 !el      common /srutu/ icall
14927       logical :: lprn
14928 !el local variables
14929       integer :: iint,itypi,itypi1,itypj
14930       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij,&
14931                       sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
14932       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
14933       evdw=0.0D0
14934 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14935       evdw=0.0D0
14936       lprn=.false.
14937 !     if (icall.eq.0) lprn=.true.
14938 !el      ind=0
14939       do i=iatsc_s,iatsc_e
14940         itypi=itype(i,1)
14941         if (itypi.eq.ntyp1) cycle
14942         itypi1=itype(i+1,1)
14943         xi=c(1,nres+i)
14944         yi=c(2,nres+i)
14945         zi=c(3,nres+i)
14946         call to_box(xi,yi,zi)
14947         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14948         dxi=dc_norm(1,nres+i)
14949         dyi=dc_norm(2,nres+i)
14950         dzi=dc_norm(3,nres+i)
14951
14952 !        dsci_inv=dsc_inv(itypi)
14953         dsci_inv=vbld_inv(i+nres)
14954 !
14955 ! Calculate SC interaction energy.
14956 !
14957         do iint=1,nint_gr(i)
14958           do j=istart(i,iint),iend(i,iint)
14959 !el            ind=ind+1
14960             itypj=itype(j,1)
14961             if (itypj.eq.ntyp1) cycle
14962 !            dscj_inv=dsc_inv(itypj)
14963             dscj_inv=vbld_inv(j+nres)
14964             sig0ij=sigma(itypi,itypj)
14965             r0ij=r0(itypi,itypj)
14966             chi1=chi(itypi,itypj)
14967             chi2=chi(itypj,itypi)
14968             chi12=chi1*chi2
14969             chip1=chip(itypi)
14970             chip2=chip(itypj)
14971             chip12=chip1*chip2
14972             alf1=alp(itypi)
14973             alf2=alp(itypj)
14974             alf12=0.5D0*(alf1+alf2)
14975             xj=c(1,nres+j)-xi
14976             yj=c(2,nres+j)-yi
14977             zj=c(3,nres+j)-zi
14978             call to_box(xj,yj,zj)
14979             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14980             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14981             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14982             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14983             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14984             xj=boxshift(xj-xi,boxxsize)
14985             yj=boxshift(yj-yi,boxysize)
14986             zj=boxshift(zj-zi,boxzsize)
14987             dxj=dc_norm(1,nres+j)
14988             dyj=dc_norm(2,nres+j)
14989             dzj=dc_norm(3,nres+j)
14990             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14991             rij=dsqrt(rrij)
14992
14993             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14994
14995             if (sss.lt.1.0d0) then
14996
14997 ! Calculate angle-dependent terms of energy and contributions to their
14998 ! derivatives.
14999               call sc_angular
15000               sigsq=1.0D0/sigsq
15001               sig=sig0ij*dsqrt(sigsq)
15002               rij_shift=1.0D0/rij-sig+r0ij
15003 ! I hate to put IF's in the loops, but here don't have another choice!!!!
15004               if (rij_shift.le.0.0D0) then
15005                 evdw=1.0D20
15006                 return
15007               endif
15008               sigder=-sig*sigsq
15009 !---------------------------------------------------------------
15010               rij_shift=1.0D0/rij_shift
15011               fac=rij_shift**expon
15012               e1=fac*fac*aa_aq(itypi,itypj)
15013               e2=fac*bb_aq(itypi,itypj)
15014               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
15015               eps2der=evdwij*eps3rt
15016               eps3der=evdwij*eps2rt
15017               fac_augm=rrij**expon
15018               e_augm=augm(itypi,itypj)*fac_augm
15019               evdwij=evdwij*eps2rt*eps3rt
15020               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
15021               if (lprn) then
15022               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
15023               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
15024               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
15025                 restyp(itypi,1),i,restyp(itypj,1),j,&
15026                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
15027                 chi1,chi2,chip1,chip2,&
15028                 eps1,eps2rt**2,eps3rt**2,&
15029                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
15030                 evdwij+e_augm
15031               endif
15032 ! Calculate gradient components.
15033               e1=e1*eps1*eps2rt**2*eps3rt**2
15034               fac=-expon*(e1+evdwij)*rij_shift
15035               sigder=fac*sigder
15036               fac=rij*fac-2*expon*rrij*e_augm
15037 ! Calculate the radial part of the gradient
15038               gg(1)=xj*fac
15039               gg(2)=yj*fac
15040               gg(3)=zj*fac
15041 ! Calculate angular part of the gradient.
15042               call sc_grad_scale(1.0d0-sss)
15043             endif
15044           enddo      ! j
15045         enddo        ! iint
15046       enddo          ! i
15047       end subroutine egbv_long
15048 !-----------------------------------------------------------------------------
15049       subroutine egbv_short(evdw)
15050 !
15051 ! This subroutine calculates the interaction energy of nonbonded side chains
15052 ! assuming the Gay-Berne-Vorobjev potential of interaction.
15053 !
15054       use calc_data
15055 !      implicit real*8 (a-h,o-z)
15056 !      include 'DIMENSIONS'
15057 !      include 'COMMON.GEO'
15058 !      include 'COMMON.VAR'
15059 !      include 'COMMON.LOCAL'
15060 !      include 'COMMON.CHAIN'
15061 !      include 'COMMON.DERIV'
15062 !      include 'COMMON.NAMES'
15063 !      include 'COMMON.INTERACT'
15064 !      include 'COMMON.IOUNITS'
15065 !      include 'COMMON.CALC'
15066       use comm_srutu
15067 !el      integer :: icall
15068 !el      common /srutu/ icall
15069       logical :: lprn
15070 !el local variables
15071       integer :: iint,itypi,itypi1,itypj
15072       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift,&
15073                       sslipi,ssgradlipi, sslipj,ssgradlipj,aa,bb
15074       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
15075       evdw=0.0D0
15076 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
15077       evdw=0.0D0
15078       lprn=.false.
15079 !     if (icall.eq.0) lprn=.true.
15080 !el      ind=0
15081       do i=iatsc_s,iatsc_e
15082         itypi=itype(i,1)
15083         if (itypi.eq.ntyp1) cycle
15084         itypi1=itype(i+1,1)
15085         xi=c(1,nres+i)
15086         yi=c(2,nres+i)
15087         zi=c(3,nres+i)
15088         dxi=dc_norm(1,nres+i)
15089         dyi=dc_norm(2,nres+i)
15090         dzi=dc_norm(3,nres+i)
15091         call to_box(xi,yi,zi)
15092         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
15093 !        dsci_inv=dsc_inv(itypi)
15094         dsci_inv=vbld_inv(i+nres)
15095 !
15096 ! Calculate SC interaction energy.
15097 !
15098         do iint=1,nint_gr(i)
15099           do j=istart(i,iint),iend(i,iint)
15100 !el            ind=ind+1
15101             itypj=itype(j,1)
15102             if (itypj.eq.ntyp1) cycle
15103 !            dscj_inv=dsc_inv(itypj)
15104             dscj_inv=vbld_inv(j+nres)
15105             sig0ij=sigma(itypi,itypj)
15106             r0ij=r0(itypi,itypj)
15107             chi1=chi(itypi,itypj)
15108             chi2=chi(itypj,itypi)
15109             chi12=chi1*chi2
15110             chip1=chip(itypi)
15111             chip2=chip(itypj)
15112             chip12=chip1*chip2
15113             alf1=alp(itypi)
15114             alf2=alp(itypj)
15115             alf12=0.5D0*(alf1+alf2)
15116             xj=c(1,nres+j)-xi
15117             yj=c(2,nres+j)-yi
15118             zj=c(3,nres+j)-zi
15119             call to_box(xj,yj,zj)
15120             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15121             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15122             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15123             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15124             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15125             xj=boxshift(xj-xi,boxxsize)
15126             yj=boxshift(yj-yi,boxysize)
15127             zj=boxshift(zj-zi,boxzsize)
15128             dxj=dc_norm(1,nres+j)
15129             dyj=dc_norm(2,nres+j)
15130             dzj=dc_norm(3,nres+j)
15131             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15132             rij=dsqrt(rrij)
15133
15134             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
15135
15136             if (sss.gt.0.0d0) then
15137
15138 ! Calculate angle-dependent terms of energy and contributions to their
15139 ! derivatives.
15140               call sc_angular
15141               sigsq=1.0D0/sigsq
15142               sig=sig0ij*dsqrt(sigsq)
15143               rij_shift=1.0D0/rij-sig+r0ij
15144 ! I hate to put IF's in the loops, but here don't have another choice!!!!
15145               if (rij_shift.le.0.0D0) then
15146                 evdw=1.0D20
15147                 return
15148               endif
15149               sigder=-sig*sigsq
15150 !---------------------------------------------------------------
15151               rij_shift=1.0D0/rij_shift
15152               fac=rij_shift**expon
15153               e1=fac*fac*aa_aq(itypi,itypj)
15154               e2=fac*bb_aq(itypi,itypj)
15155               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
15156               eps2der=evdwij*eps3rt
15157               eps3der=evdwij*eps2rt
15158               fac_augm=rrij**expon
15159               e_augm=augm(itypi,itypj)*fac_augm
15160               evdwij=evdwij*eps2rt*eps3rt
15161               evdw=evdw+(evdwij+e_augm)*sss
15162               if (lprn) then
15163               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
15164               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
15165               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
15166                 restyp(itypi,1),i,restyp(itypj,1),j,&
15167                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
15168                 chi1,chi2,chip1,chip2,&
15169                 eps1,eps2rt**2,eps3rt**2,&
15170                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
15171                 evdwij+e_augm
15172               endif
15173 ! Calculate gradient components.
15174               e1=e1*eps1*eps2rt**2*eps3rt**2
15175               fac=-expon*(e1+evdwij)*rij_shift
15176               sigder=fac*sigder
15177               fac=rij*fac-2*expon*rrij*e_augm
15178 ! Calculate the radial part of the gradient
15179               gg(1)=xj*fac
15180               gg(2)=yj*fac
15181               gg(3)=zj*fac
15182 ! Calculate angular part of the gradient.
15183               call sc_grad_scale(sss)
15184             endif
15185           enddo      ! j
15186         enddo        ! iint
15187       enddo          ! i
15188       end subroutine egbv_short
15189 !-----------------------------------------------------------------------------
15190       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15191 !
15192 ! This subroutine calculates the average interaction energy and its gradient
15193 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
15194 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
15195 ! The potential depends both on the distance of peptide-group centers and on
15196 ! the orientation of the CA-CA virtual bonds.
15197 !
15198 !      implicit real*8 (a-h,o-z)
15199
15200       use comm_locel
15201 #ifdef MPI
15202       include 'mpif.h'
15203 #endif
15204 !      include 'DIMENSIONS'
15205 !      include 'COMMON.CONTROL'
15206 !      include 'COMMON.SETUP'
15207 !      include 'COMMON.IOUNITS'
15208 !      include 'COMMON.GEO'
15209 !      include 'COMMON.VAR'
15210 !      include 'COMMON.LOCAL'
15211 !      include 'COMMON.CHAIN'
15212 !      include 'COMMON.DERIV'
15213 !      include 'COMMON.INTERACT'
15214 !      include 'COMMON.CONTACTS'
15215 !      include 'COMMON.TORSION'
15216 !      include 'COMMON.VECTORS'
15217 !      include 'COMMON.FFIELD'
15218 !      include 'COMMON.TIME1'
15219       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
15220       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
15221       real(kind=8),dimension(2,2) :: acipa !el,a_temp
15222 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
15223       real(kind=8),dimension(4) :: muij
15224 !el      integer :: num_conti,j1,j2
15225 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
15226 !el                   dz_normi,xmedi,ymedi,zmedi
15227 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
15228 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15229 !el          num_conti,j1,j2
15230 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15231 #ifdef MOMENT
15232       real(kind=8) :: scal_el=1.0d0
15233 #else
15234       real(kind=8) :: scal_el=0.5d0
15235 #endif
15236 ! 12/13/98
15237 ! 13-go grudnia roku pamietnego...
15238       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
15239                                              0.0d0,1.0d0,0.0d0,&
15240                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
15241 !el local variables
15242       integer :: i,j,k
15243       real(kind=8) :: fac
15244       real(kind=8) :: dxj,dyj,dzj
15245       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
15246
15247 !      allocate(num_cont_hb(nres)) !(maxres)
15248 !d      write(iout,*) 'In EELEC'
15249 !d      do i=1,nloctyp
15250 !d        write(iout,*) 'Type',i
15251 !d        write(iout,*) 'B1',B1(:,i)
15252 !d        write(iout,*) 'B2',B2(:,i)
15253 !d        write(iout,*) 'CC',CC(:,:,i)
15254 !d        write(iout,*) 'DD',DD(:,:,i)
15255 !d        write(iout,*) 'EE',EE(:,:,i)
15256 !d      enddo
15257 !d      call check_vecgrad
15258 !d      stop
15259       if (icheckgrad.eq.1) then
15260         do i=1,nres-1
15261           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
15262           do k=1,3
15263             dc_norm(k,i)=dc(k,i)*fac
15264           enddo
15265 !          write (iout,*) 'i',i,' fac',fac
15266         enddo
15267       endif
15268       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
15269           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
15270           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
15271 !        call vec_and_deriv
15272 #ifdef TIMING
15273         time01=MPI_Wtime()
15274 #endif
15275 !        print *, "before set matrices"
15276         call set_matrices
15277 !        print *,"after set martices"
15278 #ifdef TIMING
15279         time_mat=time_mat+MPI_Wtime()-time01
15280 #endif
15281       endif
15282 !d      do i=1,nres-1
15283 !d        write (iout,*) 'i=',i
15284 !d        do k=1,3
15285 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
15286 !d        enddo
15287 !d        do k=1,3
15288 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
15289 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
15290 !d        enddo
15291 !d      enddo
15292       t_eelecij=0.0d0
15293       ees=0.0D0
15294       evdw1=0.0D0
15295       eel_loc=0.0d0
15296       eello_turn3=0.0d0
15297       eello_turn4=0.0d0
15298 !el      ind=0
15299       do i=1,nres
15300         num_cont_hb(i)=0
15301       enddo
15302 !d      print '(a)','Enter EELEC'
15303 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
15304 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
15305 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
15306       do i=1,nres
15307         gel_loc_loc(i)=0.0d0
15308         gcorr_loc(i)=0.0d0
15309       enddo
15310 !
15311 !
15312 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
15313 !
15314 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
15315 !
15316       do i=iturn3_start,iturn3_end
15317         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
15318         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
15319         dxi=dc(1,i)
15320         dyi=dc(2,i)
15321         dzi=dc(3,i)
15322         dx_normi=dc_norm(1,i)
15323         dy_normi=dc_norm(2,i)
15324         dz_normi=dc_norm(3,i)
15325         xmedi=c(1,i)+0.5d0*dxi
15326         ymedi=c(2,i)+0.5d0*dyi
15327         zmedi=c(3,i)+0.5d0*dzi
15328         call to_box(xmedi,ymedi,zmedi)
15329         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
15330         num_conti=0
15331         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
15332         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
15333         num_cont_hb(i)=num_conti
15334       enddo
15335       do i=iturn4_start,iturn4_end
15336         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
15337           .or. itype(i+3,1).eq.ntyp1 &
15338           .or. itype(i+4,1).eq.ntyp1) cycle
15339         dxi=dc(1,i)
15340         dyi=dc(2,i)
15341         dzi=dc(3,i)
15342         dx_normi=dc_norm(1,i)
15343         dy_normi=dc_norm(2,i)
15344         dz_normi=dc_norm(3,i)
15345         xmedi=c(1,i)+0.5d0*dxi
15346         ymedi=c(2,i)+0.5d0*dyi
15347         zmedi=c(3,i)+0.5d0*dzi
15348
15349         call to_box(xmedi,ymedi,zmedi)
15350         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
15351
15352         num_conti=num_cont_hb(i)
15353         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
15354         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
15355           call eturn4(i,eello_turn4)
15356         num_cont_hb(i)=num_conti
15357       enddo   ! i
15358 !
15359 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
15360 !
15361       do i=iatel_s,iatel_e
15362         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15363         dxi=dc(1,i)
15364         dyi=dc(2,i)
15365         dzi=dc(3,i)
15366         dx_normi=dc_norm(1,i)
15367         dy_normi=dc_norm(2,i)
15368         dz_normi=dc_norm(3,i)
15369         xmedi=c(1,i)+0.5d0*dxi
15370         ymedi=c(2,i)+0.5d0*dyi
15371         zmedi=c(3,i)+0.5d0*dzi
15372         call to_box(xmedi,ymedi,zmedi)
15373         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
15374 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
15375         num_conti=num_cont_hb(i)
15376         do j=ielstart(i),ielend(i)
15377           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15378           call eelecij_scale(i,j,ees,evdw1,eel_loc)
15379         enddo ! j
15380         num_cont_hb(i)=num_conti
15381       enddo   ! i
15382 !      write (iout,*) "Number of loop steps in EELEC:",ind
15383 !d      do i=1,nres
15384 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
15385 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
15386 !d      enddo
15387 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
15388 !cc      eel_loc=eel_loc+eello_turn3
15389 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
15390       return
15391       end subroutine eelec_scale
15392 !-----------------------------------------------------------------------------
15393       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
15394 !      implicit real*8 (a-h,o-z)
15395
15396       use comm_locel
15397 !      include 'DIMENSIONS'
15398 #ifdef MPI
15399       include "mpif.h"
15400 #endif
15401 !      include 'COMMON.CONTROL'
15402 !      include 'COMMON.IOUNITS'
15403 !      include 'COMMON.GEO'
15404 !      include 'COMMON.VAR'
15405 !      include 'COMMON.LOCAL'
15406 !      include 'COMMON.CHAIN'
15407 !      include 'COMMON.DERIV'
15408 !      include 'COMMON.INTERACT'
15409 !      include 'COMMON.CONTACTS'
15410 !      include 'COMMON.TORSION'
15411 !      include 'COMMON.VECTORS'
15412 !      include 'COMMON.FFIELD'
15413 !      include 'COMMON.TIME1'
15414       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
15415       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
15416       real(kind=8),dimension(2,2) :: acipa !el,a_temp
15417 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
15418       real(kind=8),dimension(4) :: muij
15419       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15420                     dist_temp, dist_init,sss_grad
15421       integer xshift,yshift,zshift
15422
15423 !el      integer :: num_conti,j1,j2
15424 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
15425 !el                   dz_normi,xmedi,ymedi,zmedi
15426 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
15427 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15428 !el          num_conti,j1,j2
15429 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15430 #ifdef MOMENT
15431       real(kind=8) :: scal_el=1.0d0
15432 #else
15433       real(kind=8) :: scal_el=0.5d0
15434 #endif
15435 ! 12/13/98
15436 ! 13-go grudnia roku pamietnego...
15437       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
15438                                              0.0d0,1.0d0,0.0d0,&
15439                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
15440 !el local variables
15441       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
15442       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
15443       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
15444       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
15445       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
15446       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
15447       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
15448                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
15449                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
15450                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
15451                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
15452                   ecosam,ecosbm,ecosgm,ghalf,time00,faclipij,faclipij2
15453 !      integer :: maxconts
15454 !      maxconts = nres/4
15455 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15456 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15457 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15458 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15459 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15460 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15461 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15462 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15463 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
15464 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
15465 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
15466 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
15467 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
15468
15469 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
15470 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
15471
15472 #ifdef MPI
15473           time00=MPI_Wtime()
15474 #endif
15475 !d      write (iout,*) "eelecij",i,j
15476 !el          ind=ind+1
15477           iteli=itel(i)
15478           itelj=itel(j)
15479           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15480           aaa=app(iteli,itelj)
15481           bbb=bpp(iteli,itelj)
15482           ael6i=ael6(iteli,itelj)
15483           ael3i=ael3(iteli,itelj)
15484           dxj=dc(1,j)
15485           dyj=dc(2,j)
15486           dzj=dc(3,j)
15487           dx_normj=dc_norm(1,j)
15488           dy_normj=dc_norm(2,j)
15489           dz_normj=dc_norm(3,j)
15490 !          xj=c(1,j)+0.5D0*dxj-xmedi
15491 !          yj=c(2,j)+0.5D0*dyj-ymedi
15492 !          zj=c(3,j)+0.5D0*dzj-zmedi
15493           xj=c(1,j)+0.5D0*dxj
15494           yj=c(2,j)+0.5D0*dyj
15495           zj=c(3,j)+0.5D0*dzj
15496           call to_box(xj,yj,zj)
15497           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15498           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
15499           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
15500           xj=boxshift(xj-xmedi,boxxsize)
15501           yj=boxshift(yj-ymedi,boxysize)
15502           zj=boxshift(zj-zmedi,boxzsize)
15503           rij=xj*xj+yj*yj+zj*zj
15504           rrmij=1.0D0/rij
15505           rij=dsqrt(rij)
15506           rmij=1.0D0/rij
15507 ! For extracting the short-range part of Evdwpp
15508           sss=sscale(rij/rpp(iteli,itelj))
15509             sss_ele_cut=sscale_ele(rij)
15510             sss_ele_grad=sscagrad_ele(rij)
15511             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15512 !             sss_ele_cut=1.0d0
15513 !             sss_ele_grad=0.0d0
15514             if (sss_ele_cut.le.0.0) go to 128
15515
15516           r3ij=rrmij*rmij
15517           r6ij=r3ij*r3ij
15518           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
15519           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
15520           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
15521           fac=cosa-3.0D0*cosb*cosg
15522           ev1=aaa*r6ij*r6ij
15523 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15524           if (j.eq.i+2) ev1=scal_el*ev1
15525           ev2=bbb*r6ij
15526           fac3=ael6i*r6ij
15527           fac4=ael3i*r3ij
15528           evdwij=ev1+ev2
15529           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
15530           el2=fac4*fac
15531           eesij=el1+el2
15532 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
15533           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
15534           ees=ees+eesij*sss_ele_cut
15535           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
15536 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
15537 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
15538 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
15539 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
15540
15541           if (energy_dec) then
15542               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15543               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
15544           endif
15545
15546 !
15547 ! Calculate contributions to the Cartesian gradient.
15548 !
15549 #ifdef SPLITELE
15550           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
15551           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
15552           fac1=fac
15553           erij(1)=xj*rmij
15554           erij(2)=yj*rmij
15555           erij(3)=zj*rmij
15556 !
15557 ! Radial derivatives. First process both termini of the fragment (i,j)
15558 !
15559           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
15560           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
15561           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
15562 !          do k=1,3
15563 !            ghalf=0.5D0*ggg(k)
15564 !            gelc(k,i)=gelc(k,i)+ghalf
15565 !            gelc(k,j)=gelc(k,j)+ghalf
15566 !          enddo
15567 ! 9/28/08 AL Gradient compotents will be summed only at the end
15568           do k=1,3
15569             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15570             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15571           enddo
15572 !
15573 ! Loop over residues i+1 thru j-1.
15574 !
15575 !grad          do k=i+1,j-1
15576 !grad            do l=1,3
15577 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15578 !grad            enddo
15579 !grad          enddo
15580           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
15581           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15582           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
15583           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15584           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
15585           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15586 !          do k=1,3
15587 !            ghalf=0.5D0*ggg(k)
15588 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
15589 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
15590 !          enddo
15591 ! 9/28/08 AL Gradient compotents will be summed only at the end
15592           do k=1,3
15593             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15594             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15595           enddo
15596 !
15597 ! Loop over residues i+1 thru j-1.
15598 !
15599 !grad          do k=i+1,j-1
15600 !grad            do l=1,3
15601 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
15602 !grad            enddo
15603 !grad          enddo
15604 #else
15605           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
15606           facel=(el1+eesij)*sss_ele_cut
15607           fac1=fac
15608           fac=-3*rrmij*(facvdw+facvdw+facel)
15609           erij(1)=xj*rmij
15610           erij(2)=yj*rmij
15611           erij(3)=zj*rmij
15612 !
15613 ! Radial derivatives. First process both termini of the fragment (i,j)
15614 !
15615           ggg(1)=fac*xj
15616           ggg(2)=fac*yj
15617           ggg(3)=fac*zj
15618 !          do k=1,3
15619 !            ghalf=0.5D0*ggg(k)
15620 !            gelc(k,i)=gelc(k,i)+ghalf
15621 !            gelc(k,j)=gelc(k,j)+ghalf
15622 !          enddo
15623 ! 9/28/08 AL Gradient compotents will be summed only at the end
15624           do k=1,3
15625             gelc_long(k,j)=gelc(k,j)+ggg(k)
15626             gelc_long(k,i)=gelc(k,i)-ggg(k)
15627           enddo
15628 !
15629 ! Loop over residues i+1 thru j-1.
15630 !
15631 !grad          do k=i+1,j-1
15632 !grad            do l=1,3
15633 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15634 !grad            enddo
15635 !grad          enddo
15636 ! 9/28/08 AL Gradient compotents will be summed only at the end
15637           ggg(1)=facvdw*xj
15638           ggg(2)=facvdw*yj
15639           ggg(3)=facvdw*zj
15640           do k=1,3
15641             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15642             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15643           enddo
15644 #endif
15645 !
15646 ! Angular part
15647 !
15648           ecosa=2.0D0*fac3*fac1+fac4
15649           fac4=-3.0D0*fac4
15650           fac3=-6.0D0*fac3
15651           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
15652           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
15653           do k=1,3
15654             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15655             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15656           enddo
15657 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
15658 !d   &          (dcosg(k),k=1,3)
15659           do k=1,3
15660             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
15661           enddo
15662 !          do k=1,3
15663 !            ghalf=0.5D0*ggg(k)
15664 !            gelc(k,i)=gelc(k,i)+ghalf
15665 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
15666 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15667 !            gelc(k,j)=gelc(k,j)+ghalf
15668 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
15669 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15670 !          enddo
15671 !grad          do k=i+1,j-1
15672 !grad            do l=1,3
15673 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15674 !grad            enddo
15675 !grad          enddo
15676           do k=1,3
15677             gelc(k,i)=gelc(k,i) &
15678                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15679                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
15680                      *sss_ele_cut
15681             gelc(k,j)=gelc(k,j) &
15682                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15683                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15684                      *sss_ele_cut
15685             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15686             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15687           enddo
15688           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
15689               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
15690               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15691 !
15692 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
15693 !   energy of a peptide unit is assumed in the form of a second-order
15694 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
15695 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
15696 !   are computed for EVERY pair of non-contiguous peptide groups.
15697 !
15698           if (j.lt.nres-1) then
15699             j1=j+1
15700             j2=j-1
15701           else
15702             j1=j-1
15703             j2=j-2
15704           endif
15705           kkk=0
15706           do k=1,2
15707             do l=1,2
15708               kkk=kkk+1
15709               muij(kkk)=mu(k,i)*mu(l,j)
15710             enddo
15711           enddo
15712 !d         write (iout,*) 'EELEC: i',i,' j',j
15713 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
15714 !d          write(iout,*) 'muij',muij
15715           ury=scalar(uy(1,i),erij)
15716           urz=scalar(uz(1,i),erij)
15717           vry=scalar(uy(1,j),erij)
15718           vrz=scalar(uz(1,j),erij)
15719           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
15720           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
15721           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
15722           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
15723           fac=dsqrt(-ael6i)*r3ij
15724           a22=a22*fac
15725           a23=a23*fac
15726           a32=a32*fac
15727           a33=a33*fac
15728 !d          write (iout,'(4i5,4f10.5)')
15729 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
15730 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
15731 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
15732 !d     &      uy(:,j),uz(:,j)
15733 !d          write (iout,'(4f10.5)')
15734 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
15735 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
15736 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
15737 !d           write (iout,'(9f10.5/)')
15738 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
15739 ! Derivatives of the elements of A in virtual-bond vectors
15740           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
15741           do k=1,3
15742             uryg(k,1)=scalar(erder(1,k),uy(1,i))
15743             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
15744             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
15745             urzg(k,1)=scalar(erder(1,k),uz(1,i))
15746             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
15747             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
15748             vryg(k,1)=scalar(erder(1,k),uy(1,j))
15749             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
15750             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
15751             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
15752             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
15753             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
15754           enddo
15755 ! Compute radial contributions to the gradient
15756           facr=-3.0d0*rrmij
15757           a22der=a22*facr
15758           a23der=a23*facr
15759           a32der=a32*facr
15760           a33der=a33*facr
15761           agg(1,1)=a22der*xj
15762           agg(2,1)=a22der*yj
15763           agg(3,1)=a22der*zj
15764           agg(1,2)=a23der*xj
15765           agg(2,2)=a23der*yj
15766           agg(3,2)=a23der*zj
15767           agg(1,3)=a32der*xj
15768           agg(2,3)=a32der*yj
15769           agg(3,3)=a32der*zj
15770           agg(1,4)=a33der*xj
15771           agg(2,4)=a33der*yj
15772           agg(3,4)=a33der*zj
15773 ! Add the contributions coming from er
15774           fac3=-3.0d0*fac
15775           do k=1,3
15776             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
15777             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
15778             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
15779             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
15780           enddo
15781           do k=1,3
15782 ! Derivatives in DC(i)
15783 !grad            ghalf1=0.5d0*agg(k,1)
15784 !grad            ghalf2=0.5d0*agg(k,2)
15785 !grad            ghalf3=0.5d0*agg(k,3)
15786 !grad            ghalf4=0.5d0*agg(k,4)
15787             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
15788             -3.0d0*uryg(k,2)*vry)!+ghalf1
15789             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
15790             -3.0d0*uryg(k,2)*vrz)!+ghalf2
15791             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
15792             -3.0d0*urzg(k,2)*vry)!+ghalf3
15793             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
15794             -3.0d0*urzg(k,2)*vrz)!+ghalf4
15795 ! Derivatives in DC(i+1)
15796             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
15797             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
15798             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
15799             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
15800             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
15801             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
15802             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
15803             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
15804 ! Derivatives in DC(j)
15805             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
15806             -3.0d0*vryg(k,2)*ury)!+ghalf1
15807             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
15808             -3.0d0*vrzg(k,2)*ury)!+ghalf2
15809             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
15810             -3.0d0*vryg(k,2)*urz)!+ghalf3
15811             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
15812             -3.0d0*vrzg(k,2)*urz)!+ghalf4
15813 ! Derivatives in DC(j+1) or DC(nres-1)
15814             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
15815             -3.0d0*vryg(k,3)*ury)
15816             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
15817             -3.0d0*vrzg(k,3)*ury)
15818             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
15819             -3.0d0*vryg(k,3)*urz)
15820             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
15821             -3.0d0*vrzg(k,3)*urz)
15822 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
15823 !grad              do l=1,4
15824 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
15825 !grad              enddo
15826 !grad            endif
15827           enddo
15828           acipa(1,1)=a22
15829           acipa(1,2)=a23
15830           acipa(2,1)=a32
15831           acipa(2,2)=a33
15832           a22=-a22
15833           a23=-a23
15834           do l=1,2
15835             do k=1,3
15836               agg(k,l)=-agg(k,l)
15837               aggi(k,l)=-aggi(k,l)
15838               aggi1(k,l)=-aggi1(k,l)
15839               aggj(k,l)=-aggj(k,l)
15840               aggj1(k,l)=-aggj1(k,l)
15841             enddo
15842           enddo
15843           if (j.lt.nres-1) then
15844             a22=-a22
15845             a32=-a32
15846             do l=1,3,2
15847               do k=1,3
15848                 agg(k,l)=-agg(k,l)
15849                 aggi(k,l)=-aggi(k,l)
15850                 aggi1(k,l)=-aggi1(k,l)
15851                 aggj(k,l)=-aggj(k,l)
15852                 aggj1(k,l)=-aggj1(k,l)
15853               enddo
15854             enddo
15855           else
15856             a22=-a22
15857             a23=-a23
15858             a32=-a32
15859             a33=-a33
15860             do l=1,4
15861               do k=1,3
15862                 agg(k,l)=-agg(k,l)
15863                 aggi(k,l)=-aggi(k,l)
15864                 aggi1(k,l)=-aggi1(k,l)
15865                 aggj(k,l)=-aggj(k,l)
15866                 aggj1(k,l)=-aggj1(k,l)
15867               enddo
15868             enddo
15869           endif
15870           ENDIF ! WCORR
15871           IF (wel_loc.gt.0.0d0) THEN
15872 ! Contribution to the local-electrostatic energy coming from the i-j pair
15873           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
15874            +a33*muij(4)
15875 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
15876 !           print *,"EELLOC",i,gel_loc_loc(i-1)
15877           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
15878                   'eelloc',i,j,eel_loc_ij
15879 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
15880
15881           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
15882 ! Partial derivatives in virtual-bond dihedral angles gamma
15883           if (i.gt.1) &
15884           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
15885                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
15886                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
15887                  *sss_ele_cut
15888           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
15889                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
15890                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
15891                  *sss_ele_cut
15892            xtemp(1)=xj
15893            xtemp(2)=yj
15894            xtemp(3)=zj
15895
15896 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
15897           do l=1,3
15898             ggg(l)=(agg(l,1)*muij(1)+ &
15899                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
15900             *sss_ele_cut &
15901              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
15902
15903             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
15904             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
15905 !grad            ghalf=0.5d0*ggg(l)
15906 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
15907 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
15908           enddo
15909 !grad          do k=i+1,j2
15910 !grad            do l=1,3
15911 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
15912 !grad            enddo
15913 !grad          enddo
15914 ! Remaining derivatives of eello
15915           do l=1,3
15916             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
15917                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
15918             *sss_ele_cut
15919
15920             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
15921                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
15922             *sss_ele_cut
15923
15924             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
15925                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
15926             *sss_ele_cut
15927
15928             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
15929                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
15930             *sss_ele_cut
15931
15932           enddo
15933           ENDIF
15934 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
15935 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
15936           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
15937              .and. num_conti.le.maxconts) then
15938 !            write (iout,*) i,j," entered corr"
15939 !
15940 ! Calculate the contact function. The ith column of the array JCONT will
15941 ! contain the numbers of atoms that make contacts with the atom I (of numbers
15942 ! greater than I). The arrays FACONT and GACONT will contain the values of
15943 ! the contact function and its derivative.
15944 !           r0ij=1.02D0*rpp(iteli,itelj)
15945 !           r0ij=1.11D0*rpp(iteli,itelj)
15946             r0ij=2.20D0*rpp(iteli,itelj)
15947 !           r0ij=1.55D0*rpp(iteli,itelj)
15948             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
15949 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15950             if (fcont.gt.0.0D0) then
15951               num_conti=num_conti+1
15952               if (num_conti.gt.maxconts) then
15953 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15954                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
15955                                ' will skip next contacts for this conf.',num_conti
15956               else
15957                 jcont_hb(num_conti,i)=j
15958 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
15959 !d     &           " jcont_hb",jcont_hb(num_conti,i)
15960                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
15961                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15962 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
15963 !  terms.
15964                 d_cont(num_conti,i)=rij
15965 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
15966 !     --- Electrostatic-interaction matrix ---
15967                 a_chuj(1,1,num_conti,i)=a22
15968                 a_chuj(1,2,num_conti,i)=a23
15969                 a_chuj(2,1,num_conti,i)=a32
15970                 a_chuj(2,2,num_conti,i)=a33
15971 !     --- Gradient of rij
15972                 do kkk=1,3
15973                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
15974                 enddo
15975                 kkll=0
15976                 do k=1,2
15977                   do l=1,2
15978                     kkll=kkll+1
15979                     do m=1,3
15980                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
15981                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
15982                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
15983                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
15984                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
15985                     enddo
15986                   enddo
15987                 enddo
15988                 ENDIF
15989                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
15990 ! Calculate contact energies
15991                 cosa4=4.0D0*cosa
15992                 wij=cosa-3.0D0*cosb*cosg
15993                 cosbg1=cosb+cosg
15994                 cosbg2=cosb-cosg
15995 !               fac3=dsqrt(-ael6i)/r0ij**3
15996                 fac3=dsqrt(-ael6i)*r3ij
15997 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
15998                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
15999                 if (ees0tmp.gt.0) then
16000                   ees0pij=dsqrt(ees0tmp)
16001                 else
16002                   ees0pij=0
16003                 endif
16004 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
16005                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
16006                 if (ees0tmp.gt.0) then
16007                   ees0mij=dsqrt(ees0tmp)
16008                 else
16009                   ees0mij=0
16010                 endif
16011 !               ees0mij=0.0D0
16012                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
16013                      *sss_ele_cut
16014
16015                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
16016                      *sss_ele_cut
16017
16018 ! Diagnostics. Comment out or remove after debugging!
16019 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
16020 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
16021 !               ees0m(num_conti,i)=0.0D0
16022 ! End diagnostics.
16023 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
16024 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
16025 ! Angular derivatives of the contact function
16026                 ees0pij1=fac3/ees0pij
16027                 ees0mij1=fac3/ees0mij
16028                 fac3p=-3.0D0*fac3*rrmij
16029                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
16030                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
16031 !               ees0mij1=0.0D0
16032                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
16033                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
16034                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
16035                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
16036                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
16037                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
16038                 ecosap=ecosa1+ecosa2
16039                 ecosbp=ecosb1+ecosb2
16040                 ecosgp=ecosg1+ecosg2
16041                 ecosam=ecosa1-ecosa2
16042                 ecosbm=ecosb1-ecosb2
16043                 ecosgm=ecosg1-ecosg2
16044 ! Diagnostics
16045 !               ecosap=ecosa1
16046 !               ecosbp=ecosb1
16047 !               ecosgp=ecosg1
16048 !               ecosam=0.0D0
16049 !               ecosbm=0.0D0
16050 !               ecosgm=0.0D0
16051 ! End diagnostics
16052                 facont_hb(num_conti,i)=fcont
16053                 fprimcont=fprimcont/rij
16054 !d              facont_hb(num_conti,i)=1.0D0
16055 ! Following line is for diagnostics.
16056 !d              fprimcont=0.0D0
16057                 do k=1,3
16058                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
16059                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
16060                 enddo
16061                 do k=1,3
16062                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
16063                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
16064                 enddo
16065 !                gggp(1)=gggp(1)+ees0pijp*xj
16066 !                gggp(2)=gggp(2)+ees0pijp*yj
16067 !                gggp(3)=gggp(3)+ees0pijp*zj
16068 !                gggm(1)=gggm(1)+ees0mijp*xj
16069 !                gggm(2)=gggm(2)+ees0mijp*yj
16070 !                gggm(3)=gggm(3)+ees0mijp*zj
16071                 gggp(1)=gggp(1)+ees0pijp*xj &
16072                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
16073                 gggp(2)=gggp(2)+ees0pijp*yj &
16074                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
16075                 gggp(3)=gggp(3)+ees0pijp*zj &
16076                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
16077
16078                 gggm(1)=gggm(1)+ees0mijp*xj &
16079                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
16080
16081                 gggm(2)=gggm(2)+ees0mijp*yj &
16082                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
16083
16084                 gggm(3)=gggm(3)+ees0mijp*zj &
16085                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
16086
16087 ! Derivatives due to the contact function
16088                 gacont_hbr(1,num_conti,i)=fprimcont*xj
16089                 gacont_hbr(2,num_conti,i)=fprimcont*yj
16090                 gacont_hbr(3,num_conti,i)=fprimcont*zj
16091                 do k=1,3
16092 !
16093 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
16094 !          following the change of gradient-summation algorithm.
16095 !
16096 !grad                  ghalfp=0.5D0*gggp(k)
16097 !grad                  ghalfm=0.5D0*gggm(k)
16098 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
16099 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16100 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
16101 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
16102 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16103 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
16104 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
16105 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
16106 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16107 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
16108 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
16109 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16110 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
16111 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
16112                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
16113                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16114                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
16115                      *sss_ele_cut
16116
16117                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
16118                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16119                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
16120                      *sss_ele_cut
16121
16122                   gacontp_hb3(k,num_conti,i)=gggp(k) &
16123                      *sss_ele_cut
16124
16125                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
16126                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16127                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
16128                      *sss_ele_cut
16129
16130                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
16131                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16132                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
16133                      *sss_ele_cut
16134
16135                   gacontm_hb3(k,num_conti,i)=gggm(k) &
16136                      *sss_ele_cut
16137
16138                 enddo
16139               ENDIF ! wcorr
16140               endif  ! num_conti.le.maxconts
16141             endif  ! fcont.gt.0
16142           endif    ! j.gt.i+1
16143           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
16144             do k=1,4
16145               do l=1,3
16146                 ghalf=0.5d0*agg(l,k)
16147                 aggi(l,k)=aggi(l,k)+ghalf
16148                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
16149                 aggj(l,k)=aggj(l,k)+ghalf
16150               enddo
16151             enddo
16152             if (j.eq.nres-1 .and. i.lt.j-2) then
16153               do k=1,4
16154                 do l=1,3
16155                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
16156                 enddo
16157               enddo
16158             endif
16159           endif
16160  128      continue
16161 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
16162       return
16163       end subroutine eelecij_scale
16164 !-----------------------------------------------------------------------------
16165       subroutine evdwpp_short(evdw1)
16166 !
16167 ! Compute Evdwpp
16168 !
16169 !      implicit real*8 (a-h,o-z)
16170 !      include 'DIMENSIONS'
16171 !      include 'COMMON.CONTROL'
16172 !      include 'COMMON.IOUNITS'
16173 !      include 'COMMON.GEO'
16174 !      include 'COMMON.VAR'
16175 !      include 'COMMON.LOCAL'
16176 !      include 'COMMON.CHAIN'
16177 !      include 'COMMON.DERIV'
16178 !      include 'COMMON.INTERACT'
16179 !      include 'COMMON.CONTACTS'
16180 !      include 'COMMON.TORSION'
16181 !      include 'COMMON.VECTORS'
16182 !      include 'COMMON.FFIELD'
16183       real(kind=8),dimension(3) :: ggg
16184 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
16185 #ifdef MOMENT
16186       real(kind=8) :: scal_el=1.0d0
16187 #else
16188       real(kind=8) :: scal_el=0.5d0
16189 #endif
16190 !el local variables
16191       integer :: i,j,k,iteli,itelj,num_conti,isubchap
16192       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
16193       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
16194                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
16195                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
16196       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16197                     dist_temp, dist_init,sss_grad,sslipi,ssgradlipi,&
16198                    sslipj,ssgradlipj,faclipij2
16199       integer xshift,yshift,zshift
16200
16201
16202       evdw1=0.0D0
16203 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
16204 !     & " iatel_e_vdw",iatel_e_vdw
16205       call flush(iout)
16206       do i=iatel_s_vdw,iatel_e_vdw
16207         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
16208         dxi=dc(1,i)
16209         dyi=dc(2,i)
16210         dzi=dc(3,i)
16211         dx_normi=dc_norm(1,i)
16212         dy_normi=dc_norm(2,i)
16213         dz_normi=dc_norm(3,i)
16214         xmedi=c(1,i)+0.5d0*dxi
16215         ymedi=c(2,i)+0.5d0*dyi
16216         zmedi=c(3,i)+0.5d0*dzi
16217         call to_box(xmedi,ymedi,zmedi)
16218         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
16219         num_conti=0
16220 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
16221 !     &   ' ielend',ielend_vdw(i)
16222         call flush(iout)
16223         do j=ielstart_vdw(i),ielend_vdw(i)
16224           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
16225 !el          ind=ind+1
16226           iteli=itel(i)
16227           itelj=itel(j)
16228           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
16229           aaa=app(iteli,itelj)
16230           bbb=bpp(iteli,itelj)
16231           dxj=dc(1,j)
16232           dyj=dc(2,j)
16233           dzj=dc(3,j)
16234           dx_normj=dc_norm(1,j)
16235           dy_normj=dc_norm(2,j)
16236           dz_normj=dc_norm(3,j)
16237 !          xj=c(1,j)+0.5D0*dxj-xmedi
16238 !          yj=c(2,j)+0.5D0*dyj-ymedi
16239 !          zj=c(3,j)+0.5D0*dzj-zmedi
16240           xj=c(1,j)+0.5D0*dxj
16241           yj=c(2,j)+0.5D0*dyj
16242           zj=c(3,j)+0.5D0*dzj
16243           call to_box(xj,yj,zj)
16244           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
16245           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
16246           xj=boxshift(xj-xmedi,boxxsize)
16247           yj=boxshift(yj-ymedi,boxysize)
16248           zj=boxshift(zj-zmedi,boxzsize)
16249           rij=xj*xj+yj*yj+zj*zj
16250           rrmij=1.0D0/rij
16251           rij=dsqrt(rij)
16252           sss=sscale(rij/rpp(iteli,itelj))
16253             sss_ele_cut=sscale_ele(rij)
16254             sss_ele_grad=sscagrad_ele(rij)
16255             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
16256             if (sss_ele_cut.le.0.0) cycle
16257           if (sss.gt.0.0d0) then
16258             rmij=1.0D0/rij
16259             r3ij=rrmij*rmij
16260             r6ij=r3ij*r3ij
16261             ev1=aaa*r6ij*r6ij
16262 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
16263             if (j.eq.i+2) ev1=scal_el*ev1
16264             ev2=bbb*r6ij
16265             evdwij=ev1+ev2
16266             if (energy_dec) then
16267               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
16268             endif
16269             evdw1=evdw1+evdwij*sss*sss_ele_cut
16270 !
16271 ! Calculate contributions to the Cartesian gradient.
16272 !
16273             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
16274 !            ggg(1)=facvdw*xj
16275 !            ggg(2)=facvdw*yj
16276 !            ggg(3)=facvdw*zj
16277           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
16278           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
16279           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
16280           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
16281           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
16282           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
16283
16284             do k=1,3
16285               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
16286               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
16287             enddo
16288           endif
16289         enddo ! j
16290       enddo   ! i
16291       return
16292       end subroutine evdwpp_short
16293 !-----------------------------------------------------------------------------
16294       subroutine escp_long(evdw2,evdw2_14)
16295 !
16296 ! This subroutine calculates the excluded-volume interaction energy between
16297 ! peptide-group centers and side chains and its gradient in virtual-bond and
16298 ! side-chain vectors.
16299 !
16300 !      implicit real*8 (a-h,o-z)
16301 !      include 'DIMENSIONS'
16302 !      include 'COMMON.GEO'
16303 !      include 'COMMON.VAR'
16304 !      include 'COMMON.LOCAL'
16305 !      include 'COMMON.CHAIN'
16306 !      include 'COMMON.DERIV'
16307 !      include 'COMMON.INTERACT'
16308 !      include 'COMMON.FFIELD'
16309 !      include 'COMMON.IOUNITS'
16310 !      include 'COMMON.CONTROL'
16311       real(kind=8),dimension(3) :: ggg
16312 !el local variables
16313       integer :: i,iint,j,k,iteli,itypj,subchap
16314       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
16315       real(kind=8) :: evdw2,evdw2_14,evdwij
16316       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16317                     dist_temp, dist_init
16318
16319       evdw2=0.0D0
16320       evdw2_14=0.0d0
16321 !d    print '(a)','Enter ESCP'
16322 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
16323       do i=iatscp_s,iatscp_e
16324         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
16325         iteli=itel(i)
16326         xi=0.5D0*(c(1,i)+c(1,i+1))
16327         yi=0.5D0*(c(2,i)+c(2,i+1))
16328         zi=0.5D0*(c(3,i)+c(3,i+1))
16329         call to_box(xi,yi,zi)
16330         do iint=1,nscp_gr(i)
16331
16332         do j=iscpstart(i,iint),iscpend(i,iint)
16333           itypj=itype(j,1)
16334           if (itypj.eq.ntyp1) cycle
16335 ! Uncomment following three lines for SC-p interactions
16336 !         xj=c(1,nres+j)-xi
16337 !         yj=c(2,nres+j)-yi
16338 !         zj=c(3,nres+j)-zi
16339 ! Uncomment following three lines for Ca-p interactions
16340           xj=c(1,j)
16341           yj=c(2,j)
16342           zj=c(3,j)
16343           call to_box(xj,yj,zj)
16344           xj=boxshift(xj-xi,boxxsize)
16345           yj=boxshift(yj-yi,boxysize)
16346           zj=boxshift(zj-zi,boxzsize)
16347           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16348
16349           rij=dsqrt(1.0d0/rrij)
16350             sss_ele_cut=sscale_ele(rij)
16351             sss_ele_grad=sscagrad_ele(rij)
16352 !            print *,sss_ele_cut,sss_ele_grad,&
16353 !            (rij),r_cut_ele,rlamb_ele
16354             if (sss_ele_cut.le.0.0) cycle
16355           sss=sscale((rij/rscp(itypj,iteli)))
16356           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
16357           if (sss.lt.1.0d0) then
16358
16359             fac=rrij**expon2
16360             e1=fac*fac*aad(itypj,iteli)
16361             e2=fac*bad(itypj,iteli)
16362             if (iabs(j-i) .le. 2) then
16363               e1=scal14*e1
16364               e2=scal14*e2
16365               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
16366             endif
16367             evdwij=e1+e2
16368             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
16369             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
16370                 'evdw2',i,j,sss,evdwij
16371 !
16372 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
16373 !
16374             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
16375             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
16376             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
16377             ggg(1)=xj*fac
16378             ggg(2)=yj*fac
16379             ggg(3)=zj*fac
16380 ! Uncomment following three lines for SC-p interactions
16381 !           do k=1,3
16382 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16383 !           enddo
16384 ! Uncomment following line for SC-p interactions
16385 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16386             do k=1,3
16387               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
16388               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
16389             enddo
16390           endif
16391         enddo
16392
16393         enddo ! iint
16394       enddo ! i
16395       do i=1,nct
16396         do j=1,3
16397           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
16398           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
16399           gradx_scp(j,i)=expon*gradx_scp(j,i)
16400         enddo
16401       enddo
16402 !******************************************************************************
16403 !
16404 !                              N O T E !!!
16405 !
16406 ! To save time the factor EXPON has been extracted from ALL components
16407 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
16408 ! use!
16409 !
16410 !******************************************************************************
16411       return
16412       end subroutine escp_long
16413 !-----------------------------------------------------------------------------
16414       subroutine escp_short(evdw2,evdw2_14)
16415 !
16416 ! This subroutine calculates the excluded-volume interaction energy between
16417 ! peptide-group centers and side chains and its gradient in virtual-bond and
16418 ! side-chain vectors.
16419 !
16420 !      implicit real*8 (a-h,o-z)
16421 !      include 'DIMENSIONS'
16422 !      include 'COMMON.GEO'
16423 !      include 'COMMON.VAR'
16424 !      include 'COMMON.LOCAL'
16425 !      include 'COMMON.CHAIN'
16426 !      include 'COMMON.DERIV'
16427 !      include 'COMMON.INTERACT'
16428 !      include 'COMMON.FFIELD'
16429 !      include 'COMMON.IOUNITS'
16430 !      include 'COMMON.CONTROL'
16431       real(kind=8),dimension(3) :: ggg
16432 !el local variables
16433       integer :: i,iint,j,k,iteli,itypj,subchap
16434       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
16435       real(kind=8) :: evdw2,evdw2_14,evdwij
16436       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16437                     dist_temp, dist_init
16438
16439       evdw2=0.0D0
16440       evdw2_14=0.0d0
16441 !d    print '(a)','Enter ESCP'
16442 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
16443       do i=iatscp_s,iatscp_e
16444         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
16445         iteli=itel(i)
16446         xi=0.5D0*(c(1,i)+c(1,i+1))
16447         yi=0.5D0*(c(2,i)+c(2,i+1))
16448         zi=0.5D0*(c(3,i)+c(3,i+1))
16449         call to_box(xi,yi,zi)
16450         if (zi.lt.0) zi=zi+boxzsize
16451
16452         do iint=1,nscp_gr(i)
16453
16454         do j=iscpstart(i,iint),iscpend(i,iint)
16455           itypj=itype(j,1)
16456           if (itypj.eq.ntyp1) cycle
16457 ! Uncomment following three lines for SC-p interactions
16458 !         xj=c(1,nres+j)-xi
16459 !         yj=c(2,nres+j)-yi
16460 !         zj=c(3,nres+j)-zi
16461 ! Uncomment following three lines for Ca-p interactions
16462 !          xj=c(1,j)-xi
16463 !          yj=c(2,j)-yi
16464 !          zj=c(3,j)-zi
16465           xj=c(1,j)
16466           yj=c(2,j)
16467           zj=c(3,j)
16468           call to_box(xj,yj,zj)
16469           xj=boxshift(xj-xi,boxxsize)
16470           yj=boxshift(yj-yi,boxysize)
16471           zj=boxshift(zj-zi,boxzsize)
16472           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16473           rij=dsqrt(1.0d0/rrij)
16474             sss_ele_cut=sscale_ele(rij)
16475             sss_ele_grad=sscagrad_ele(rij)
16476 !            print *,sss_ele_cut,sss_ele_grad,&
16477 !            (rij),r_cut_ele,rlamb_ele
16478             if (sss_ele_cut.le.0.0) cycle
16479           sss=sscale(rij/rscp(itypj,iteli))
16480           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
16481           if (sss.gt.0.0d0) then
16482
16483             fac=rrij**expon2
16484             e1=fac*fac*aad(itypj,iteli)
16485             e2=fac*bad(itypj,iteli)
16486             if (iabs(j-i) .le. 2) then
16487               e1=scal14*e1
16488               e2=scal14*e2
16489               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
16490             endif
16491             evdwij=e1+e2
16492             evdw2=evdw2+evdwij*sss*sss_ele_cut
16493             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
16494                 'evdw2',i,j,sss,evdwij
16495 !
16496 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
16497 !
16498             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
16499             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
16500             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
16501
16502             ggg(1)=xj*fac
16503             ggg(2)=yj*fac
16504             ggg(3)=zj*fac
16505 ! Uncomment following three lines for SC-p interactions
16506 !           do k=1,3
16507 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16508 !           enddo
16509 ! Uncomment following line for SC-p interactions
16510 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16511             do k=1,3
16512               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
16513               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
16514             enddo
16515           endif
16516         enddo
16517
16518         enddo ! iint
16519       enddo ! i
16520       do i=1,nct
16521         do j=1,3
16522           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
16523           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
16524           gradx_scp(j,i)=expon*gradx_scp(j,i)
16525         enddo
16526       enddo
16527 !******************************************************************************
16528 !
16529 !                              N O T E !!!
16530 !
16531 ! To save time the factor EXPON has been extracted from ALL components
16532 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
16533 ! use!
16534 !
16535 !******************************************************************************
16536       return
16537       end subroutine escp_short
16538 !-----------------------------------------------------------------------------
16539 ! energy_p_new-sep_barrier.F
16540 !-----------------------------------------------------------------------------
16541       subroutine sc_grad_scale(scalfac)
16542 !      implicit real*8 (a-h,o-z)
16543       use calc_data
16544 !      include 'DIMENSIONS'
16545 !      include 'COMMON.CHAIN'
16546 !      include 'COMMON.DERIV'
16547 !      include 'COMMON.CALC'
16548 !      include 'COMMON.IOUNITS'
16549       real(kind=8),dimension(3) :: dcosom1,dcosom2
16550       real(kind=8) :: scalfac
16551 !el local variables
16552 !      integer :: i,j,k,l
16553
16554       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
16555       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
16556       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
16557            -2.0D0*alf12*eps3der+sigder*sigsq_om12
16558 ! diagnostics only
16559 !      eom1=0.0d0
16560 !      eom2=0.0d0
16561 !      eom12=evdwij*eps1_om12
16562 ! end diagnostics
16563 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
16564 !     &  " sigder",sigder
16565 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
16566 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
16567       do k=1,3
16568         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
16569         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
16570       enddo
16571       do k=1,3
16572         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
16573          *sss_ele_cut
16574       enddo
16575 !      write (iout,*) "gg",(gg(k),k=1,3)
16576       do k=1,3
16577         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
16578                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
16579                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
16580                  *sss_ele_cut
16581         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
16582                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
16583                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
16584          *sss_ele_cut
16585 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
16586 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
16587 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
16588 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
16589       enddo
16590 !
16591 ! Calculate the components of the gradient in DC and X
16592 !
16593       do l=1,3
16594         gvdwc(l,i)=gvdwc(l,i)-gg(l)
16595         gvdwc(l,j)=gvdwc(l,j)+gg(l)
16596       enddo
16597       return
16598       end subroutine sc_grad_scale
16599 !-----------------------------------------------------------------------------
16600 ! energy_split-sep.F
16601 !-----------------------------------------------------------------------------
16602       subroutine etotal_long(energia)
16603 !
16604 ! Compute the long-range slow-varying contributions to the energy
16605 !
16606 !      implicit real*8 (a-h,o-z)
16607 !      include 'DIMENSIONS'
16608       use MD_data, only: totT,usampl,eq_time
16609 #ifndef ISNAN
16610       external proc_proc
16611 #ifdef WINPGI
16612 !MS$ATTRIBUTES C ::  proc_proc
16613 #endif
16614 #endif
16615 #ifdef MPI
16616       include "mpif.h"
16617       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
16618 #endif
16619 !      include 'COMMON.SETUP'
16620 !      include 'COMMON.IOUNITS'
16621 !      include 'COMMON.FFIELD'
16622 !      include 'COMMON.DERIV'
16623 !      include 'COMMON.INTERACT'
16624 !      include 'COMMON.SBRIDGE'
16625 !      include 'COMMON.CHAIN'
16626 !      include 'COMMON.VAR'
16627 !      include 'COMMON.LOCAL'
16628 !      include 'COMMON.MD'
16629       real(kind=8),dimension(0:n_ene) :: energia
16630 !el local variables
16631       integer :: i,n_corr,n_corr1,ierror,ierr
16632       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
16633                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
16634                   ecorr,ecorr5,ecorr6,eturn6,time00, ehomology_constr
16635 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
16636 !elwrite(iout,*)"in etotal long"
16637
16638       if (modecalc.eq.12.or.modecalc.eq.14) then
16639 #ifdef MPI
16640 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
16641 #else
16642         call int_from_cart1(.false.)
16643 #endif
16644       endif
16645 !elwrite(iout,*)"in etotal long"
16646       ehomology_constr=0.0d0
16647 #ifdef MPI
16648 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
16649 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16650       call flush(iout)
16651       if (nfgtasks.gt.1) then
16652         time00=MPI_Wtime()
16653 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16654         if (fg_rank.eq.0) then
16655           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
16656 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16657 !          call flush(iout)
16658 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16659 ! FG slaves as WEIGHTS array.
16660           weights_(1)=wsc
16661           weights_(2)=wscp
16662           weights_(3)=welec
16663           weights_(4)=wcorr
16664           weights_(5)=wcorr5
16665           weights_(6)=wcorr6
16666           weights_(7)=wel_loc
16667           weights_(8)=wturn3
16668           weights_(9)=wturn4
16669           weights_(10)=wturn6
16670           weights_(11)=wang
16671           weights_(12)=wscloc
16672           weights_(13)=wtor
16673           weights_(14)=wtor_d
16674           weights_(15)=wstrain
16675           weights_(16)=wvdwpp
16676           weights_(17)=wbond
16677           weights_(18)=scal14
16678           weights_(21)=wsccor
16679 ! FG Master broadcasts the WEIGHTS_ array
16680           call MPI_Bcast(weights_(1),n_ene,&
16681               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16682         else
16683 ! FG slaves receive the WEIGHTS array
16684           call MPI_Bcast(weights(1),n_ene,&
16685               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16686           wsc=weights(1)
16687           wscp=weights(2)
16688           welec=weights(3)
16689           wcorr=weights(4)
16690           wcorr5=weights(5)
16691           wcorr6=weights(6)
16692           wel_loc=weights(7)
16693           wturn3=weights(8)
16694           wturn4=weights(9)
16695           wturn6=weights(10)
16696           wang=weights(11)
16697           wscloc=weights(12)
16698           wtor=weights(13)
16699           wtor_d=weights(14)
16700           wstrain=weights(15)
16701           wvdwpp=weights(16)
16702           wbond=weights(17)
16703           scal14=weights(18)
16704           wsccor=weights(21)
16705         endif
16706         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
16707           king,FG_COMM,IERR)
16708          time_Bcast=time_Bcast+MPI_Wtime()-time00
16709          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
16710 !        call chainbuild_cart
16711 !        call int_from_cart1(.false.)
16712       endif
16713 !      write (iout,*) 'Processor',myrank,
16714 !     &  ' calling etotal_short ipot=',ipot
16715 !      call flush(iout)
16716 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16717 #endif
16718 !d    print *,'nnt=',nnt,' nct=',nct
16719 !
16720 !elwrite(iout,*)"in etotal long"
16721 ! Compute the side-chain and electrostatic interaction energy
16722 !
16723       goto (101,102,103,104,105,106) ipot
16724 ! Lennard-Jones potential.
16725   101 call elj_long(evdw)
16726 !d    print '(a)','Exit ELJ'
16727       goto 107
16728 ! Lennard-Jones-Kihara potential (shifted).
16729   102 call eljk_long(evdw)
16730       goto 107
16731 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16732   103 call ebp_long(evdw)
16733       goto 107
16734 ! Gay-Berne potential (shifted LJ, angular dependence).
16735   104 call egb_long(evdw)
16736       goto 107
16737 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16738   105 call egbv_long(evdw)
16739       goto 107
16740 ! Soft-sphere potential
16741   106 call e_softsphere(evdw)
16742 !
16743 ! Calculate electrostatic (H-bonding) energy of the main chain.
16744 !
16745   107 continue
16746       call vec_and_deriv
16747       if (ipot.lt.6) then
16748 #ifdef SPLITELE
16749          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
16750              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16751              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16752              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16753 #else
16754          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
16755              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16756              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16757              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16758 #endif
16759            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
16760          else
16761             ees=0
16762             evdw1=0
16763             eel_loc=0
16764             eello_turn3=0
16765             eello_turn4=0
16766          endif
16767       else
16768 !        write (iout,*) "Soft-spheer ELEC potential"
16769         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
16770          eello_turn4)
16771       endif
16772 !
16773 ! Calculate excluded-volume interaction energy between peptide groups
16774 ! and side chains.
16775 !
16776       if (ipot.lt.6) then
16777        if(wscp.gt.0d0) then
16778         call escp_long(evdw2,evdw2_14)
16779        else
16780         evdw2=0
16781         evdw2_14=0
16782        endif
16783       else
16784         call escp_soft_sphere(evdw2,evdw2_14)
16785       endif
16786 !
16787 ! 12/1/95 Multi-body terms
16788 !
16789       n_corr=0
16790       n_corr1=0
16791       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
16792           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
16793          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
16794 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
16795 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
16796       else
16797          ecorr=0.0d0
16798          ecorr5=0.0d0
16799          ecorr6=0.0d0
16800          eturn6=0.0d0
16801       endif
16802       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
16803          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
16804       endif
16805 !
16806 ! If performing constraint dynamics, call the constraint energy
16807 !  after the equilibration time
16808       if(usampl.and.totT.gt.eq_time) then
16809          call EconstrQ
16810          call Econstr_back
16811       else
16812          Uconst=0.0d0
16813          Uconst_back=0.0d0
16814       endif
16815 !
16816 ! Sum the energies
16817 !
16818       do i=1,n_ene
16819         energia(i)=0.0d0
16820       enddo
16821       energia(1)=evdw
16822 #ifdef SCP14
16823       energia(2)=evdw2-evdw2_14
16824       energia(18)=evdw2_14
16825 #else
16826       energia(2)=evdw2
16827       energia(18)=0.0d0
16828 #endif
16829 #ifdef SPLITELE
16830       energia(3)=ees
16831       energia(16)=evdw1
16832 #else
16833       energia(3)=ees+evdw1
16834       energia(16)=0.0d0
16835 #endif
16836       energia(4)=ecorr
16837       energia(5)=ecorr5
16838       energia(6)=ecorr6
16839       energia(7)=eel_loc
16840       energia(8)=eello_turn3
16841       energia(9)=eello_turn4
16842       energia(10)=eturn6
16843       energia(20)=Uconst+Uconst_back
16844       energia(51)=ehomology_constr
16845       call sum_energy(energia,.true.)
16846 !      write (iout,*) "Exit ETOTAL_LONG"
16847       call flush(iout)
16848       return
16849       end subroutine etotal_long
16850 !-----------------------------------------------------------------------------
16851       subroutine etotal_short(energia)
16852 !
16853 ! Compute the short-range fast-varying contributions to the energy
16854 !
16855 !      implicit real*8 (a-h,o-z)
16856 !      include 'DIMENSIONS'
16857 #ifndef ISNAN
16858       external proc_proc
16859 #ifdef WINPGI
16860 !MS$ATTRIBUTES C ::  proc_proc
16861 #endif
16862 #endif
16863 #ifdef MPI
16864       include "mpif.h"
16865       integer :: ierror,ierr
16866       real(kind=8),dimension(n_ene) :: weights_
16867       real(kind=8) :: time00
16868 #endif
16869 !      include 'COMMON.SETUP'
16870 !      include 'COMMON.IOUNITS'
16871 !      include 'COMMON.FFIELD'
16872 !      include 'COMMON.DERIV'
16873 !      include 'COMMON.INTERACT'
16874 !      include 'COMMON.SBRIDGE'
16875 !      include 'COMMON.CHAIN'
16876 !      include 'COMMON.VAR'
16877 !      include 'COMMON.LOCAL'
16878       real(kind=8),dimension(0:n_ene) :: energia
16879 !el local variables
16880       integer :: i,nres6
16881       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
16882       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr, &
16883                       ehomology_constr
16884       nres6=6*nres
16885
16886 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
16887 !      call flush(iout)
16888       if (modecalc.eq.12.or.modecalc.eq.14) then
16889 #ifdef MPI
16890         if (fg_rank.eq.0) call int_from_cart1(.false.)
16891 #else
16892         call int_from_cart1(.false.)
16893 #endif
16894       endif
16895 #ifdef MPI
16896 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
16897 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16898 !      call flush(iout)
16899       if (nfgtasks.gt.1) then
16900         time00=MPI_Wtime()
16901 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16902         if (fg_rank.eq.0) then
16903           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
16904 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16905 !          call flush(iout)
16906 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16907 ! FG slaves as WEIGHTS array.
16908           weights_(1)=wsc
16909           weights_(2)=wscp
16910           weights_(3)=welec
16911           weights_(4)=wcorr
16912           weights_(5)=wcorr5
16913           weights_(6)=wcorr6
16914           weights_(7)=wel_loc
16915           weights_(8)=wturn3
16916           weights_(9)=wturn4
16917           weights_(10)=wturn6
16918           weights_(11)=wang
16919           weights_(12)=wscloc
16920           weights_(13)=wtor
16921           weights_(14)=wtor_d
16922           weights_(15)=wstrain
16923           weights_(16)=wvdwpp
16924           weights_(17)=wbond
16925           weights_(18)=scal14
16926           weights_(21)=wsccor
16927 ! FG Master broadcasts the WEIGHTS_ array
16928           call MPI_Bcast(weights_(1),n_ene,&
16929               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16930         else
16931 ! FG slaves receive the WEIGHTS array
16932           call MPI_Bcast(weights(1),n_ene,&
16933               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16934           wsc=weights(1)
16935           wscp=weights(2)
16936           welec=weights(3)
16937           wcorr=weights(4)
16938           wcorr5=weights(5)
16939           wcorr6=weights(6)
16940           wel_loc=weights(7)
16941           wturn3=weights(8)
16942           wturn4=weights(9)
16943           wturn6=weights(10)
16944           wang=weights(11)
16945           wscloc=weights(12)
16946           wtor=weights(13)
16947           wtor_d=weights(14)
16948           wstrain=weights(15)
16949           wvdwpp=weights(16)
16950           wbond=weights(17)
16951           scal14=weights(18)
16952           wsccor=weights(21)
16953         endif
16954 !        write (iout,*),"Processor",myrank," BROADCAST weights"
16955         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
16956           king,FG_COMM,IERR)
16957 !        write (iout,*) "Processor",myrank," BROADCAST c"
16958         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
16959           king,FG_COMM,IERR)
16960 !        write (iout,*) "Processor",myrank," BROADCAST dc"
16961         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
16962           king,FG_COMM,IERR)
16963 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
16964         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
16965           king,FG_COMM,IERR)
16966 !        write (iout,*) "Processor",myrank," BROADCAST theta"
16967         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
16968           king,FG_COMM,IERR)
16969 !        write (iout,*) "Processor",myrank," BROADCAST phi"
16970         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
16971           king,FG_COMM,IERR)
16972 !        write (iout,*) "Processor",myrank," BROADCAST alph"
16973         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
16974           king,FG_COMM,IERR)
16975 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
16976         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
16977           king,FG_COMM,IERR)
16978 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
16979         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
16980           king,FG_COMM,IERR)
16981          time_Bcast=time_Bcast+MPI_Wtime()-time00
16982 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
16983       endif
16984 !      write (iout,*) 'Processor',myrank,
16985 !     &  ' calling etotal_short ipot=',ipot
16986 !      call flush(iout)
16987 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16988 #endif
16989 !      call int_from_cart1(.false.)
16990 !
16991 ! Compute the side-chain and electrostatic interaction energy
16992 !
16993       goto (101,102,103,104,105,106) ipot
16994 ! Lennard-Jones potential.
16995   101 call elj_short(evdw)
16996 !d    print '(a)','Exit ELJ'
16997       goto 107
16998 ! Lennard-Jones-Kihara potential (shifted).
16999   102 call eljk_short(evdw)
17000       goto 107
17001 ! Berne-Pechukas potential (dilated LJ, angular dependence).
17002   103 call ebp_short(evdw)
17003       goto 107
17004 ! Gay-Berne potential (shifted LJ, angular dependence).
17005   104 call egb_short(evdw)
17006       goto 107
17007 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
17008   105 call egbv_short(evdw)
17009       goto 107
17010 ! Soft-sphere potential - already dealt with in the long-range part
17011   106 evdw=0.0d0
17012 !  106 call e_softsphere_short(evdw)
17013 !
17014 ! Calculate electrostatic (H-bonding) energy of the main chain.
17015 !
17016   107 continue
17017 !
17018 ! Calculate the short-range part of Evdwpp
17019 !
17020       call evdwpp_short(evdw1)
17021 !
17022 ! Calculate the short-range part of ESCp
17023 !
17024       if (ipot.lt.6) then
17025        call escp_short(evdw2,evdw2_14)
17026       endif
17027 !
17028 ! Calculate the bond-stretching energy
17029 !
17030       call ebond(estr)
17031 !
17032 ! Calculate the disulfide-bridge and other energy and the contributions
17033 ! from other distance constraints.
17034       call edis(ehpb)
17035 !
17036 ! Calculate the virtual-bond-angle energy.
17037 !
17038 ! Calculate the SC local energy.
17039 !
17040       call vec_and_deriv
17041       call esc(escloc)
17042 !
17043       if (wang.gt.0d0) then
17044        if (tor_mode.eq.0) then
17045            call ebend(ebe)
17046        else
17047 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
17048 !C energy function
17049         call ebend_kcc(ebe)
17050        endif
17051       else
17052           ebe=0.0d0
17053       endif
17054       ethetacnstr=0.0d0
17055       if (with_theta_constr) call etheta_constr(ethetacnstr)
17056
17057 !       write(iout,*) "in etotal afer ebe",ipot
17058
17059 !      print *,"Processor",myrank," computed UB"
17060 !
17061 ! Calculate the SC local energy.
17062 !
17063       call esc(escloc)
17064 !elwrite(iout,*) "in etotal afer esc",ipot
17065 !      print *,"Processor",myrank," computed USC"
17066 !
17067 ! Calculate the virtual-bond torsional energy.
17068 !
17069 !d    print *,'nterm=',nterm
17070 !      if (wtor.gt.0) then
17071 !       call etor(etors,edihcnstr)
17072 !      else
17073 !       etors=0
17074 !       edihcnstr=0
17075 !      endif
17076       if (wtor.gt.0.0d0) then
17077          if (tor_mode.eq.0) then
17078            call etor(etors)
17079           else
17080 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
17081 !C energy function
17082         call etor_kcc(etors)
17083          endif
17084       else
17085            etors=0.0d0
17086       endif
17087       edihcnstr=0.0d0
17088       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
17089
17090 ! Calculate the virtual-bond torsional energy.
17091 !
17092 !
17093 ! 6/23/01 Calculate double-torsional energy
17094 !
17095       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
17096       call etor_d(etors_d)
17097       endif
17098 !
17099 ! Homology restraints
17100 !
17101       if (constr_homology.ge.1) then
17102         call e_modeller(ehomology_constr)
17103 !      print *,"tu"
17104       else
17105         ehomology_constr=0.0d0
17106       endif
17107
17108 !
17109 ! 21/5/07 Calculate local sicdechain correlation energy
17110 !
17111       if (wsccor.gt.0.0d0) then
17112        call eback_sc_corr(esccor)
17113       else
17114        esccor=0.0d0
17115       endif
17116 !
17117 ! Put energy components into an array
17118 !
17119       do i=1,n_ene
17120        energia(i)=0.0d0
17121       enddo
17122       energia(1)=evdw
17123 #ifdef SCP14
17124       energia(2)=evdw2-evdw2_14
17125       energia(18)=evdw2_14
17126 #else
17127       energia(2)=evdw2
17128       energia(18)=0.0d0
17129 #endif
17130 #ifdef SPLITELE
17131       energia(16)=evdw1
17132 #else
17133       energia(3)=evdw1
17134 #endif
17135       energia(11)=ebe
17136       energia(12)=escloc
17137       energia(13)=etors
17138       energia(14)=etors_d
17139       energia(15)=ehpb
17140       energia(17)=estr
17141       energia(19)=edihcnstr
17142       energia(21)=esccor
17143       energia(51)=ehomology_constr
17144 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
17145       call flush(iout)
17146       call sum_energy(energia,.true.)
17147 !      write (iout,*) "Exit ETOTAL_SHORT"
17148       call flush(iout)
17149       return
17150       end subroutine etotal_short
17151 !-----------------------------------------------------------------------------
17152 ! gnmr1.f
17153 !-----------------------------------------------------------------------------
17154       real(kind=8) function gnmr1(y,ymin,ymax)
17155 !      implicit none
17156       real(kind=8) :: y,ymin,ymax
17157       real(kind=8) :: wykl=4.0d0
17158       if (y.lt.ymin) then
17159         gnmr1=(ymin-y)**wykl/wykl
17160       else if (y.gt.ymax) then
17161        gnmr1=(y-ymax)**wykl/wykl
17162       else
17163        gnmr1=0.0d0
17164       endif
17165       return
17166       end function gnmr1
17167 !-----------------------------------------------------------------------------
17168       real(kind=8) function gnmr1prim(y,ymin,ymax)
17169 !      implicit none
17170       real(kind=8) :: y,ymin,ymax
17171       real(kind=8) :: wykl=4.0d0
17172       if (y.lt.ymin) then
17173        gnmr1prim=-(ymin-y)**(wykl-1)
17174       else if (y.gt.ymax) then
17175        gnmr1prim=(y-ymax)**(wykl-1)
17176       else
17177        gnmr1prim=0.0d0
17178       endif
17179       return
17180       end function gnmr1prim
17181 !----------------------------------------------------------------------------
17182       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
17183       real(kind=8) y,ymin,ymax,sigma
17184       real(kind=8) wykl /4.0d0/
17185       if (y.lt.ymin) then
17186         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
17187       else if (y.gt.ymax) then
17188        rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
17189       else
17190         rlornmr1=0.0d0
17191       endif
17192       return
17193       end function rlornmr1
17194 !------------------------------------------------------------------------------
17195       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
17196       real(kind=8) y,ymin,ymax,sigma
17197       real(kind=8) wykl /4.0d0/
17198       if (y.lt.ymin) then
17199         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
17200         ((ymin-y)**wykl+sigma**wykl)**2
17201       else if (y.gt.ymax) then
17202          rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
17203         ((y-ymax)**wykl+sigma**wykl)**2
17204       else
17205        rlornmr1prim=0.0d0
17206       endif
17207       return
17208       end function rlornmr1prim
17209
17210       real(kind=8) function harmonic(y,ymax)
17211 !      implicit none
17212       real(kind=8) :: y,ymax
17213       real(kind=8) :: wykl=2.0d0
17214       harmonic=(y-ymax)**wykl
17215       return
17216       end function harmonic
17217 !-----------------------------------------------------------------------------
17218       real(kind=8) function harmonicprim(y,ymax)
17219       real(kind=8) :: y,ymin,ymax
17220       real(kind=8) :: wykl=2.0d0
17221       harmonicprim=(y-ymax)*wykl
17222       return
17223       end function harmonicprim
17224 !-----------------------------------------------------------------------------
17225 ! gradient_p.F
17226 !-----------------------------------------------------------------------------
17227       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
17228
17229       use io_base, only:intout,briefout
17230 !      implicit real*8 (a-h,o-z)
17231 !      include 'DIMENSIONS'
17232 !      include 'COMMON.CHAIN'
17233 !      include 'COMMON.DERIV'
17234 !      include 'COMMON.VAR'
17235 !      include 'COMMON.INTERACT'
17236 !      include 'COMMON.FFIELD'
17237 !      include 'COMMON.MD'
17238 !      include 'COMMON.IOUNITS'
17239       real(kind=8),external :: ufparm
17240       integer :: uiparm(1)
17241       real(kind=8) :: urparm(1)
17242       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
17243       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
17244       integer :: n,nf,ind,ind1,i,k,j
17245 !
17246 ! This subroutine calculates total internal coordinate gradient.
17247 ! Depending on the number of function evaluations, either whole energy
17248 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
17249 ! internal coordinates are reevaluated or only the cartesian-in-internal
17250 ! coordinate derivatives are evaluated. The subroutine was designed to work
17251 ! with SUMSL.
17252 !
17253 !
17254       icg=mod(nf,2)+1
17255
17256 !d      print *,'grad',nf,icg
17257       if (nf-nfl+1) 20,30,40
17258    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
17259 !    write (iout,*) 'grad 20'
17260       if (nf.eq.0) return
17261       goto 40
17262    30 call var_to_geom(n,x)
17263       call chainbuild
17264 !    write (iout,*) 'grad 30'
17265 !
17266 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
17267 !
17268    40 call cartder
17269 !     write (iout,*) 'grad 40'
17270 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
17271 !
17272 ! Convert the Cartesian gradient into internal-coordinate gradient.
17273 !
17274       ind=0
17275       ind1=0
17276       do i=1,nres-2
17277       gthetai=0.0D0
17278       gphii=0.0D0
17279       do j=i+1,nres-1
17280         ind=ind+1
17281 !         ind=indmat(i,j)
17282 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
17283        do k=1,3
17284        gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
17285         enddo
17286         do k=1,3
17287         gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
17288          enddo
17289        enddo
17290       do j=i+1,nres-1
17291         ind1=ind1+1
17292 !         ind1=indmat(i,j)
17293 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
17294         do k=1,3
17295           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
17296           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
17297           enddo
17298         enddo
17299       if (i.gt.1) g(i-1)=gphii
17300       if (n.gt.nphi) g(nphi+i)=gthetai
17301       enddo
17302       if (n.le.nphi+ntheta) goto 10
17303       do i=2,nres-1
17304       if (itype(i,1).ne.10) then
17305           galphai=0.0D0
17306         gomegai=0.0D0
17307         do k=1,3
17308           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
17309           enddo
17310         do k=1,3
17311           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
17312           enddo
17313           g(ialph(i,1))=galphai
17314         g(ialph(i,1)+nside)=gomegai
17315         endif
17316       enddo
17317 !
17318 ! Add the components corresponding to local energy terms.
17319 !
17320    10 continue
17321       do i=1,nvar
17322 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
17323         g(i)=g(i)+gloc(i,icg)
17324       enddo
17325 ! Uncomment following three lines for diagnostics.
17326 !d    call intout
17327 !elwrite(iout,*) "in gradient after calling intout"
17328 !d    call briefout(0,0.0d0)
17329 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
17330       return
17331       end subroutine gradient
17332 !-----------------------------------------------------------------------------
17333       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
17334
17335       use comm_chu
17336 !      implicit real*8 (a-h,o-z)
17337 !      include 'DIMENSIONS'
17338 !      include 'COMMON.DERIV'
17339 !      include 'COMMON.IOUNITS'
17340 !      include 'COMMON.GEO'
17341       integer :: n,nf
17342 !el      integer :: jjj
17343 !el      common /chuju/ jjj
17344       real(kind=8) :: energia(0:n_ene)
17345       integer :: uiparm(1)
17346       real(kind=8) :: urparm(1)
17347       real(kind=8) :: f
17348       real(kind=8),external :: ufparm
17349       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
17350 !     if (jjj.gt.0) then
17351 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
17352 !     endif
17353       nfl=nf
17354       icg=mod(nf,2)+1
17355 !d      print *,'func',nf,nfl,icg
17356       call var_to_geom(n,x)
17357       call zerograd
17358       call chainbuild
17359 !d    write (iout,*) 'ETOTAL called from FUNC'
17360       call etotal(energia)
17361       call sum_gradient
17362       f=energia(0)
17363 !     if (jjj.gt.0) then
17364 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
17365 !       write (iout,*) 'f=',etot
17366 !       jjj=0
17367 !     endif
17368       return
17369       end subroutine func
17370 !-----------------------------------------------------------------------------
17371       subroutine cartgrad
17372 !      implicit real*8 (a-h,o-z)
17373 !      include 'DIMENSIONS'
17374       use energy_data
17375       use MD_data, only: totT,usampl,eq_time
17376 #ifdef MPI
17377       include 'mpif.h'
17378 #endif
17379 !      include 'COMMON.CHAIN'
17380 !      include 'COMMON.DERIV'
17381 !      include 'COMMON.VAR'
17382 !      include 'COMMON.INTERACT'
17383 !      include 'COMMON.FFIELD'
17384 !      include 'COMMON.MD'
17385 !      include 'COMMON.IOUNITS'
17386 !      include 'COMMON.TIME1'
17387 !
17388       integer :: i,j
17389       real(kind=8) :: time00,time01
17390
17391 ! This subrouting calculates total Cartesian coordinate gradient.
17392 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
17393 !
17394 !#define DEBUG
17395 #ifdef TIMINGtime01
17396       time00=MPI_Wtime()
17397 #endif
17398       icg=1
17399       call sum_gradient
17400 #ifdef TIMING
17401 #endif
17402 !#define DEBUG
17403 !el      write (iout,*) "After sum_gradient"
17404 #ifdef DEBUG
17405       write (iout,*) "After sum_gradient"
17406       do i=1,nres-1
17407         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
17408         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
17409       enddo
17410 #endif
17411 !#undef DEBUG
17412 ! If performing constraint dynamics, add the gradients of the constraint energy
17413       if(usampl.and.totT.gt.eq_time) then
17414          do i=1,nct
17415            do j=1,3
17416              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
17417              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
17418            enddo
17419          enddo
17420          do i=1,nres-3
17421            gloc(i,icg)=gloc(i,icg)+dugamma(i)
17422          enddo
17423          do i=1,nres-2
17424            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
17425          enddo
17426       endif
17427 !elwrite (iout,*) "After sum_gradient"
17428 #ifdef TIMING
17429       time01=MPI_Wtime()
17430 #endif
17431       call intcartderiv
17432 !elwrite (iout,*) "After sum_gradient"
17433 #ifdef TIMING
17434       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
17435 #endif
17436 !     call checkintcartgrad
17437 !     write(iout,*) 'calling int_to_cart'
17438 !#define DEBUG
17439 #ifdef DEBUG
17440       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
17441 #endif
17442       do i=0,nct
17443         do j=1,3
17444           gcart(j,i)=gradc(j,i,icg)
17445           gxcart(j,i)=gradx(j,i,icg)
17446 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
17447         enddo
17448 #ifdef DEBUG
17449         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
17450           (gxcart(j,i),j=1,3),gloc(i,icg)
17451 #endif
17452       enddo
17453 #ifdef TIMING
17454       time01=MPI_Wtime()
17455 #endif
17456 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17457       call int_to_cart
17458 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17459
17460 #ifdef TIMING
17461             time_inttocart=time_inttocart+MPI_Wtime()-time01
17462 #endif
17463 #ifdef DEBUG
17464             write (iout,*) "gcart and gxcart after int_to_cart"
17465             do i=0,nres-1
17466             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
17467             (gxcart(j,i),j=1,3)
17468             enddo
17469 #endif
17470 !#undef DEBUG
17471 #ifdef CARGRAD
17472 #ifdef DEBUG
17473             write (iout,*) "CARGRAD"
17474 #endif
17475             do i=nres,0,-1
17476             do j=1,3
17477               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17478       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17479             enddo
17480       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
17481       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
17482             enddo
17483       ! Correction: dummy residues
17484             if (nnt.gt.1) then
17485               do j=1,3
17486       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
17487             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
17488             enddo
17489           endif
17490           if (nct.lt.nres) then
17491             do j=1,3
17492       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
17493             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
17494             enddo
17495           endif
17496 #endif
17497 #ifdef TIMING
17498           time_cartgrad=time_cartgrad+MPI_Wtime()-time00
17499 #endif
17500 !#undef DEBUG
17501           return
17502           end subroutine cartgrad
17503       !-----------------------------------------------------------------------------
17504           subroutine zerograd
17505       !      implicit real*8 (a-h,o-z)
17506       !      include 'DIMENSIONS'
17507       !      include 'COMMON.DERIV'
17508       !      include 'COMMON.CHAIN'
17509       !      include 'COMMON.VAR'
17510       !      include 'COMMON.MD'
17511       !      include 'COMMON.SCCOR'
17512       !
17513       !el local variables
17514           integer :: i,j,intertyp,k
17515       ! Initialize Cartesian-coordinate gradient
17516       !
17517       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
17518       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
17519
17520       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
17521       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
17522       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
17523       !      allocate(gradcorr_long(3,nres))
17524       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
17525       !      allocate(gcorr6_turn_long(3,nres))
17526       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
17527
17528       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
17529
17530       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
17531       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
17532
17533       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
17534       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
17535
17536       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
17537       !      allocate(gscloc(3,nres)) !(3,maxres)
17538       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
17539
17540
17541
17542       !      common /deriv_scloc/
17543       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
17544       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
17545       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
17546       !      common /mpgrad/
17547       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
17548
17549
17550
17551       !          gradc(j,i,icg)=0.0d0
17552       !          gradx(j,i,icg)=0.0d0
17553
17554       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
17555       !elwrite(iout,*) "icg",icg
17556           do i=-1,nres
17557           do j=1,3
17558             gvdwx(j,i)=0.0D0
17559             gradx_scp(j,i)=0.0D0
17560             gvdwc(j,i)=0.0D0
17561             gvdwc_scp(j,i)=0.0D0
17562             gvdwc_scpp(j,i)=0.0d0
17563             gelc(j,i)=0.0D0
17564             gelc_long(j,i)=0.0D0
17565             gradb(j,i)=0.0d0
17566             gradbx(j,i)=0.0d0
17567             gvdwpp(j,i)=0.0d0
17568             gel_loc(j,i)=0.0d0
17569             gel_loc_long(j,i)=0.0d0
17570             ghpbc(j,i)=0.0D0
17571             ghpbx(j,i)=0.0D0
17572             gcorr3_turn(j,i)=0.0d0
17573             gcorr4_turn(j,i)=0.0d0
17574             gradcorr(j,i)=0.0d0
17575             gradcorr_long(j,i)=0.0d0
17576             gradcorr5_long(j,i)=0.0d0
17577             gradcorr6_long(j,i)=0.0d0
17578             gcorr6_turn_long(j,i)=0.0d0
17579             gradcorr5(j,i)=0.0d0
17580             gradcorr6(j,i)=0.0d0
17581             gcorr6_turn(j,i)=0.0d0
17582             gsccorc(j,i)=0.0d0
17583             gsccorx(j,i)=0.0d0
17584             gradc(j,i,icg)=0.0d0
17585             gradx(j,i,icg)=0.0d0
17586             gscloc(j,i)=0.0d0
17587             gsclocx(j,i)=0.0d0
17588             gliptran(j,i)=0.0d0
17589             gliptranx(j,i)=0.0d0
17590             gliptranc(j,i)=0.0d0
17591             gshieldx(j,i)=0.0d0
17592             gshieldc(j,i)=0.0d0
17593             gshieldc_loc(j,i)=0.0d0
17594             gshieldx_ec(j,i)=0.0d0
17595             gshieldc_ec(j,i)=0.0d0
17596             gshieldc_loc_ec(j,i)=0.0d0
17597             gshieldx_t3(j,i)=0.0d0
17598             gshieldc_t3(j,i)=0.0d0
17599             gshieldc_loc_t3(j,i)=0.0d0
17600             gshieldx_t4(j,i)=0.0d0
17601             gshieldc_t4(j,i)=0.0d0
17602             gshieldc_loc_t4(j,i)=0.0d0
17603             gshieldx_ll(j,i)=0.0d0
17604             gshieldc_ll(j,i)=0.0d0
17605             gshieldc_loc_ll(j,i)=0.0d0
17606             gg_tube(j,i)=0.0d0
17607             gg_tube_sc(j,i)=0.0d0
17608             gradafm(j,i)=0.0d0
17609             gradb_nucl(j,i)=0.0d0
17610             gradbx_nucl(j,i)=0.0d0
17611             gvdwpp_nucl(j,i)=0.0d0
17612             gvdwpp(j,i)=0.0d0
17613             gelpp(j,i)=0.0d0
17614             gvdwpsb(j,i)=0.0d0
17615             gvdwpsb1(j,i)=0.0d0
17616             gvdwsbc(j,i)=0.0d0
17617             gvdwsbx(j,i)=0.0d0
17618             gelsbc(j,i)=0.0d0
17619             gradcorr_nucl(j,i)=0.0d0
17620             gradcorr3_nucl(j,i)=0.0d0
17621             gradxorr_nucl(j,i)=0.0d0
17622             gradxorr3_nucl(j,i)=0.0d0
17623             gelsbx(j,i)=0.0d0
17624             gsbloc(j,i)=0.0d0
17625             gsblocx(j,i)=0.0d0
17626             gradpepcat(j,i)=0.0d0
17627             gradpepcatx(j,i)=0.0d0
17628             gradcatcat(j,i)=0.0d0
17629             gvdwx_scbase(j,i)=0.0d0
17630             gvdwc_scbase(j,i)=0.0d0
17631             gvdwx_pepbase(j,i)=0.0d0
17632             gvdwc_pepbase(j,i)=0.0d0
17633             gvdwx_scpho(j,i)=0.0d0
17634             gvdwc_scpho(j,i)=0.0d0
17635             gvdwc_peppho(j,i)=0.0d0
17636             gradnuclcatx(j,i)=0.0d0
17637             gradnuclcat(j,i)=0.0d0
17638             duscdiff(j,i)=0.0d0
17639             duscdiffx(j,i)=0.0d0
17640           enddo
17641            enddo
17642           do i=0,nres
17643           do j=1,3
17644             do intertyp=1,3
17645              gloc_sc(intertyp,i,icg)=0.0d0
17646             enddo
17647           enddo
17648           enddo
17649           do i=1,nres
17650            do j=1,maxcontsshi
17651            shield_list(j,i)=0
17652           do k=1,3
17653       !C           print *,i,j,k
17654              grad_shield_side(k,j,i)=0.0d0
17655              grad_shield_loc(k,j,i)=0.0d0
17656            enddo
17657            enddo
17658            ishield_list(i)=0
17659           enddo
17660
17661       !
17662       ! Initialize the gradient of local energy terms.
17663       !
17664       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
17665       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
17666       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
17667       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
17668       !      allocate(gel_loc_turn3(nres))
17669       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
17670       !      allocate(gsccor_loc(nres))      !(maxres)
17671
17672           do i=1,4*nres
17673           gloc(i,icg)=0.0D0
17674           enddo
17675           do i=1,nres
17676           gel_loc_loc(i)=0.0d0
17677           gcorr_loc(i)=0.0d0
17678           g_corr5_loc(i)=0.0d0
17679           g_corr6_loc(i)=0.0d0
17680           gel_loc_turn3(i)=0.0d0
17681           gel_loc_turn4(i)=0.0d0
17682           gel_loc_turn6(i)=0.0d0
17683           gsccor_loc(i)=0.0d0
17684           enddo
17685       ! initialize gcart and gxcart
17686       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
17687           do i=0,nres
17688           do j=1,3
17689             gcart(j,i)=0.0d0
17690             gxcart(j,i)=0.0d0
17691           enddo
17692           enddo
17693           return
17694           end subroutine zerograd
17695       !-----------------------------------------------------------------------------
17696           real(kind=8) function fdum()
17697           fdum=0.0D0
17698           return
17699           end function fdum
17700       !-----------------------------------------------------------------------------
17701       ! intcartderiv.F
17702       !-----------------------------------------------------------------------------
17703           subroutine intcartderiv
17704       !      implicit real*8 (a-h,o-z)
17705       !      include 'DIMENSIONS'
17706 #ifdef MPI
17707           include 'mpif.h'
17708 #endif
17709       !      include 'COMMON.SETUP'
17710       !      include 'COMMON.CHAIN'
17711       !      include 'COMMON.VAR'
17712       !      include 'COMMON.GEO'
17713       !      include 'COMMON.INTERACT'
17714       !      include 'COMMON.DERIV'
17715       !      include 'COMMON.IOUNITS'
17716       !      include 'COMMON.LOCAL'
17717       !      include 'COMMON.SCCOR'
17718           real(kind=8) :: pi4,pi34
17719           real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
17720           real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
17721                   dcosomega,dsinomega !(3,3,maxres)
17722           real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
17723
17724           integer :: i,j,k
17725           real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
17726                 fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
17727                 fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
17728                 fac17,coso_inv,fac10,fac11,fac12,fac13,fac14,IERROR
17729           integer :: nres2
17730           nres2=2*nres
17731
17732       !el from module energy-------------
17733       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
17734       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
17735       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
17736
17737       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
17738       !el      allocate(dsintau(3,3,3,0:nres2))
17739       !el      allocate(dtauangle(3,3,3,0:nres2))
17740       !el      allocate(domicron(3,2,2,0:nres2))
17741       !el      allocate(dcosomicron(3,2,2,0:nres2))
17742
17743
17744
17745 #if defined(MPI) && defined(PARINTDER)
17746           if (nfgtasks.gt.1 .and. me.eq.king) &
17747           call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
17748 #endif
17749           pi4 = 0.5d0*pipol
17750           pi34 = 3*pi4
17751
17752       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
17753       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
17754
17755       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
17756           do i=1,nres
17757           do j=1,3
17758             dtheta(j,1,i)=0.0d0
17759             dtheta(j,2,i)=0.0d0
17760             dphi(j,1,i)=0.0d0
17761             dphi(j,2,i)=0.0d0
17762             dphi(j,3,i)=0.0d0
17763             dcosomicron(j,1,1,i)=0.0d0
17764             dcosomicron(j,1,2,i)=0.0d0
17765             dcosomicron(j,2,1,i)=0.0d0
17766             dcosomicron(j,2,2,i)=0.0d0
17767           enddo
17768           enddo
17769       ! Derivatives of theta's
17770 #if defined(MPI) && defined(PARINTDER)
17771       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17772           do i=max0(ithet_start-1,3),ithet_end
17773 #else
17774           do i=3,nres
17775 #endif
17776           cost=dcos(theta(i))
17777           sint=sqrt(1-cost*cost)
17778           do j=1,3
17779             dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
17780             vbld(i-1)
17781             if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
17782             dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
17783             vbld(i)
17784             if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
17785           enddo
17786           enddo
17787 #if defined(MPI) && defined(PARINTDER)
17788       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17789           do i=max0(ithet_start-1,3),ithet_end
17790 #else
17791           do i=3,nres
17792 #endif
17793           if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1).and.molnum(i).ne.5) then
17794           cost1=dcos(omicron(1,i))
17795           sint1=sqrt(1-cost1*cost1)
17796           cost2=dcos(omicron(2,i))
17797           sint2=sqrt(1-cost2*cost2)
17798            do j=1,3
17799       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
17800             dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
17801             cost1*dc_norm(j,i-2))/ &
17802             vbld(i-1)
17803             domicron(j,1,1,i)=-1.0/sint1*dcosomicron(j,1,1,i)
17804             dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
17805             +cost1*(dc_norm(j,i-1+nres)))/ &
17806             vbld(i-1+nres)
17807             domicron(j,1,2,i)=-1.0/sint1*dcosomicron(j,1,2,i)
17808       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
17809       !C Looks messy but better than if in loop
17810             dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
17811             +cost2*dc_norm(j,i-1))/ &
17812             vbld(i)
17813             domicron(j,2,1,i)=-1.0/sint2*dcosomicron(j,2,1,i)
17814             dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
17815              +cost2*(-dc_norm(j,i-1+nres)))/ &
17816             vbld(i-1+nres)
17817       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
17818             domicron(j,2,2,i)=-1.0/sint2*dcosomicron(j,2,2,i)
17819           enddo
17820            endif
17821           enddo
17822       !elwrite(iout,*) "after vbld write"
17823       ! Derivatives of phi:
17824       ! If phi is 0 or 180 degrees, then the formulas
17825       ! have to be derived by power series expansion of the
17826       ! conventional formulas around 0 and 180.
17827 #ifdef PARINTDER
17828           do i=iphi1_start,iphi1_end
17829 #else
17830           do i=4,nres
17831 #endif
17832       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
17833       ! the conventional case
17834           sint=dsin(theta(i))
17835           sint1=dsin(theta(i-1))
17836           sing=dsin(phi(i))
17837           cost=dcos(theta(i))
17838           cost1=dcos(theta(i-1))
17839           cosg=dcos(phi(i))
17840           scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
17841           fac0=1.0d0/(sint1*sint)
17842           fac1=cost*fac0
17843           fac2=cost1*fac0
17844           fac3=cosg*cost1/(sint1*sint1)
17845           fac4=cosg*cost/(sint*sint)
17846       !    Obtaining the gamma derivatives from sine derivative
17847            if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
17848              phi(i).gt.pi34.and.phi(i).le.pi.or. &
17849              phi(i).ge.-pi.and.phi(i).le.-pi34) then
17850            call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17851            call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
17852            call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17853            do j=1,3
17854             ctgt=cost/sint
17855             ctgt1=cost1/sint1
17856             cosg_inv=1.0d0/cosg
17857             if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17858             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17859               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
17860             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
17861             dsinphi(j,2,i)= &
17862               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
17863               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17864             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
17865             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
17866               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17867       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17868             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
17869             endif
17870       ! Bug fixed 3/24/05 (AL)
17871            enddo
17872       !   Obtaining the gamma derivatives from cosine derivative
17873           else
17874              do j=1,3
17875              if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17876              dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17877              dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17878              dc_norm(j,i-3))/vbld(i-2)
17879              dphi(j,1,i)=-1.0/sing*dcosphi(j,1,i)
17880              dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17881              dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17882              dcostheta(j,1,i)
17883              dphi(j,2,i)=-1.0/sing*dcosphi(j,2,i)
17884              dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17885              dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17886              dc_norm(j,i-1))/vbld(i)
17887              dphi(j,3,i)=-1.0/sing*dcosphi(j,3,i)
17888 !#define DEBUG
17889 #ifdef DEBUG
17890              write(iout,*) "just after",dphi(j,3,i),sing,dcosphi(j,3,i)
17891 #endif
17892 !#undef DEBUG
17893              endif
17894            enddo
17895           endif
17896           enddo
17897       !alculate derivative of Tauangle
17898 #ifdef PARINTDER
17899           do i=itau_start,itau_end
17900 #else
17901           do i=3,nres
17902       !elwrite(iout,*) " vecpr",i,nres
17903 #endif
17904            if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17905       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
17906       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
17907       !c dtauangle(j,intertyp,dervityp,residue number)
17908       !c INTERTYP=1 SC...Ca...Ca..Ca
17909       ! the conventional case
17910           sint=dsin(theta(i))
17911           sint1=dsin(omicron(2,i-1))
17912           sing=dsin(tauangle(1,i))
17913           cost=dcos(theta(i))
17914           cost1=dcos(omicron(2,i-1))
17915           cosg=dcos(tauangle(1,i))
17916       !elwrite(iout,*) " vecpr5",i,nres
17917           do j=1,3
17918       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
17919       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
17920           dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17921       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
17922           enddo
17923           scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
17924           fac0=1.0d0/(sint1*sint)
17925           fac1=cost*fac0
17926           fac2=cost1*fac0
17927           fac3=cosg*cost1/(sint1*sint1)
17928           fac4=cosg*cost/(sint*sint)
17929       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
17930       !    Obtaining the gamma derivatives from sine derivative
17931            if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
17932              tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
17933              tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
17934            call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17935            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
17936            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17937           do j=1,3
17938             ctgt=cost/sint
17939             ctgt1=cost1/sint1
17940             cosg_inv=1.0d0/cosg
17941             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17942            -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
17943            *vbld_inv(i-2+nres)
17944             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
17945             dsintau(j,1,2,i)= &
17946               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
17947               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17948       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
17949             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
17950       ! Bug fixed 3/24/05 (AL)
17951             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
17952               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17953       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17954             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
17955            enddo
17956       !   Obtaining the gamma derivatives from cosine derivative
17957           else
17958              do j=1,3
17959              dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17960              dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17961              (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
17962              dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
17963              dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17964              dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17965              dcostheta(j,1,i)
17966              dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
17967              dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17968              dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
17969              dc_norm(j,i-1))/vbld(i)
17970              dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
17971       !         write (iout,*) "else",i
17972            enddo
17973           endif
17974       !        do k=1,3
17975       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
17976       !        enddo
17977           enddo
17978       !C Second case Ca...Ca...Ca...SC
17979 #ifdef PARINTDER
17980           do i=itau_start,itau_end
17981 #else
17982           do i=4,nres
17983 #endif
17984            if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17985             (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
17986       ! the conventional case
17987           sint=dsin(omicron(1,i))
17988           sint1=dsin(theta(i-1))
17989           sing=dsin(tauangle(2,i))
17990           cost=dcos(omicron(1,i))
17991           cost1=dcos(theta(i-1))
17992           cosg=dcos(tauangle(2,i))
17993       !        do j=1,3
17994       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17995       !        enddo
17996           scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
17997           fac0=1.0d0/(sint1*sint)
17998           fac1=cost*fac0
17999           fac2=cost1*fac0
18000           fac3=cosg*cost1/(sint1*sint1)
18001           fac4=cosg*cost/(sint*sint)
18002       !    Obtaining the gamma derivatives from sine derivative
18003            if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
18004              tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
18005              tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
18006            call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
18007            call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
18008            call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
18009           do j=1,3
18010             ctgt=cost/sint
18011             ctgt1=cost1/sint1
18012             cosg_inv=1.0d0/cosg
18013             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
18014               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
18015       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
18016       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
18017             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
18018             dsintau(j,2,2,i)= &
18019               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
18020               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
18021       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
18022       !     & sing*ctgt*domicron(j,1,2,i),
18023       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
18024             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
18025       ! Bug fixed 3/24/05 (AL)
18026             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
18027              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
18028       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
18029             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
18030            enddo
18031       !   Obtaining the gamma derivatives from cosine derivative
18032           else
18033              do j=1,3
18034              dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
18035              dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
18036              dc_norm(j,i-3))/vbld(i-2)
18037              dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
18038              dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
18039              dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
18040              dcosomicron(j,1,1,i)
18041              dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
18042              dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
18043              dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
18044              dc_norm(j,i-1+nres))/vbld(i-1+nres)
18045              dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
18046       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
18047            enddo
18048           endif
18049           enddo
18050
18051       !CC third case SC...Ca...Ca...SC
18052 #ifdef PARINTDER
18053
18054           do i=itau_start,itau_end
18055 #else
18056           do i=3,nres
18057 #endif
18058       ! the conventional case
18059           if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
18060           (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
18061           sint=dsin(omicron(1,i))
18062           sint1=dsin(omicron(2,i-1))
18063           sing=dsin(tauangle(3,i))
18064           cost=dcos(omicron(1,i))
18065           cost1=dcos(omicron(2,i-1))
18066           cosg=dcos(tauangle(3,i))
18067           do j=1,3
18068           dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
18069       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
18070           enddo
18071           scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
18072           fac0=1.0d0/(sint1*sint)
18073           fac1=cost*fac0
18074           fac2=cost1*fac0
18075           fac3=cosg*cost1/(sint1*sint1)
18076           fac4=cosg*cost/(sint*sint)
18077       !    Obtaining the gamma derivatives from sine derivative
18078            if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
18079              tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
18080              tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
18081            call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
18082            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
18083            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
18084           do j=1,3
18085             ctgt=cost/sint
18086             ctgt1=cost1/sint1
18087             cosg_inv=1.0d0/cosg
18088             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
18089               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
18090               *vbld_inv(i-2+nres)
18091             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
18092             dsintau(j,3,2,i)= &
18093               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
18094               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
18095             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
18096       ! Bug fixed 3/24/05 (AL)
18097             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
18098               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
18099               *vbld_inv(i-1+nres)
18100       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
18101             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
18102            enddo
18103       !   Obtaining the gamma derivatives from cosine derivative
18104           else
18105              do j=1,3
18106              dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
18107              dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
18108              dc_norm2(j,i-2+nres))/vbld(i-2+nres)
18109              dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
18110              dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
18111              dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
18112              dcosomicron(j,1,1,i)
18113              dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
18114              dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
18115              dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
18116              dc_norm(j,i-1+nres))/vbld(i-1+nres)
18117              dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
18118       !          write(iout,*) "else",i
18119            enddo
18120           endif
18121           enddo
18122
18123 #ifdef CRYST_SC
18124       !   Derivatives of side-chain angles alpha and omega
18125 #if defined(MPI) && defined(PARINTDER)
18126           do i=ibond_start,ibond_end
18127 #else
18128           do i=2,nres-1
18129 #endif
18130             if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
18131              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
18132              fac6=fac5/vbld(i)
18133              fac7=fac5*fac5
18134              fac8=fac5/vbld(i+1)
18135              fac9=fac5/vbld(i+nres)
18136              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
18137              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
18138              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
18139              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
18140              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
18141              sina=sqrt(1-cosa*cosa)
18142              sino=dsin(omeg(i))
18143       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
18144              do j=1,3
18145               dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
18146               dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
18147               dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
18148               dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
18149               scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
18150               dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
18151               dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
18152               dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
18153               vbld(i+nres))
18154               dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
18155             enddo
18156       ! obtaining the derivatives of omega from sines
18157             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
18158                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
18159                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
18160                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
18161                dsin(theta(i+1)))
18162                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
18163                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
18164                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
18165                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
18166                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
18167                coso_inv=1.0d0/dcos(omeg(i))
18168                do j=1,3
18169                dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
18170                +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
18171                (sino*dc_norm(j,i-1))/vbld(i)
18172                domega(j,1,i)=coso_inv*dsinomega(j,1,i)
18173                dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
18174                +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
18175                -sino*dc_norm(j,i)/vbld(i+1)
18176                domega(j,2,i)=coso_inv*dsinomega(j,2,i)
18177                dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
18178                fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
18179                vbld(i+nres)
18180                domega(j,3,i)=coso_inv*dsinomega(j,3,i)
18181               enddo
18182              else
18183       !   obtaining the derivatives of omega from cosines
18184              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
18185              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
18186              fac12=fac10*sina
18187              fac13=fac12*fac12
18188              fac14=sina*sina
18189              do j=1,3
18190               dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
18191               dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
18192               (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
18193               fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
18194               domega(j,1,i)=-1/sino*dcosomega(j,1,i)
18195               dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
18196               dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
18197               dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
18198               (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
18199               dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
18200               domega(j,2,i)=-1/sino*dcosomega(j,2,i)
18201               dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
18202               scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
18203               (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
18204               domega(j,3,i)=-1/sino*dcosomega(j,3,i)
18205             enddo
18206             endif
18207            else
18208              do j=1,3
18209              do k=1,3
18210                dalpha(k,j,i)=0.0d0
18211                domega(k,j,i)=0.0d0
18212              enddo
18213              enddo
18214            endif
18215            enddo
18216 #endif
18217 #if defined(MPI) && defined(PARINTDER)
18218           if (nfgtasks.gt.1) then
18219 #ifdef DEBUG
18220       !d      write (iout,*) "Gather dtheta"
18221       !d      call flush(iout)
18222           write (iout,*) "dtheta before gather"
18223           do i=1,nres
18224           write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
18225           enddo
18226 #endif
18227           call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
18228           MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
18229           king,FG_COMM,IERROR)
18230 !#define DEBUG
18231 #ifdef DEBUG
18232       !d      write (iout,*) "Gather dphi"
18233       !d      call flush(iout)
18234           write (iout,*) "dphi before gather"
18235           do i=1,nres
18236           write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
18237           enddo
18238 #endif
18239 !#undef DEBUG
18240           call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
18241           MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
18242           king,FG_COMM,IERROR)
18243       !d      write (iout,*) "Gather dalpha"
18244       !d      call flush(iout)
18245 #ifdef CRYST_SC
18246           call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
18247           MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
18248           king,FG_COMM,IERROR)
18249       !d      write (iout,*) "Gather domega"
18250       !d      call flush(iout)
18251           call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
18252           MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
18253           king,FG_COMM,IERROR)
18254 #endif
18255           endif
18256 #endif
18257 !#define DEBUG
18258 #ifdef DEBUG
18259           write (iout,*) "dtheta after gather"
18260           do i=1,nres
18261           write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
18262           enddo
18263           write (iout,*) "dphi after gather"
18264           do i=1,nres
18265           write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
18266           enddo
18267           write (iout,*) "dalpha after gather"
18268           do i=1,nres
18269           write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
18270           enddo
18271           write (iout,*) "domega after gather"
18272           do i=1,nres
18273           write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
18274           enddo
18275 #endif
18276 !#undef DEBUG
18277           return
18278           end subroutine intcartderiv
18279       !-----------------------------------------------------------------------------
18280           subroutine checkintcartgrad
18281       !      implicit real*8 (a-h,o-z)
18282       !      include 'DIMENSIONS'
18283 #ifdef MPI
18284           include 'mpif.h'
18285 #endif
18286       !      include 'COMMON.CHAIN'
18287       !      include 'COMMON.VAR'
18288       !      include 'COMMON.GEO'
18289       !      include 'COMMON.INTERACT'
18290       !      include 'COMMON.DERIV'
18291       !      include 'COMMON.IOUNITS'
18292       !      include 'COMMON.SETUP'
18293           real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
18294           real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
18295           real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
18296           real(kind=8),dimension(3) :: dc_norm_s
18297           real(kind=8) :: aincr=1.0d-5
18298           integer :: i,j
18299           real(kind=8) :: dcji
18300           do i=1,nres
18301           phi_s(i)=phi(i)
18302           theta_s(i)=theta(i)
18303           alph_s(i)=alph(i)
18304           omeg_s(i)=omeg(i)
18305           enddo
18306       ! Check theta gradient
18307           write (iout,*) &
18308            "Analytical (upper) and numerical (lower) gradient of theta"
18309           write (iout,*)
18310           do i=3,nres
18311           do j=1,3
18312             dcji=dc(j,i-2)
18313             dc(j,i-2)=dcji+aincr
18314             call chainbuild_cart
18315             call int_from_cart1(.false.)
18316         dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
18317         dc(j,i-2)=dcji
18318         dcji=dc(j,i-1)
18319         dc(j,i-1)=dc(j,i-1)+aincr
18320         call chainbuild_cart
18321         dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
18322         dc(j,i-1)=dcji
18323       enddo
18324 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
18325 !el          (dtheta(j,2,i),j=1,3)
18326 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
18327 !el          (dthetanum(j,2,i),j=1,3)
18328 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
18329 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
18330 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
18331 !el        write (iout,*)
18332       enddo
18333 ! Check gamma gradient
18334       write (iout,*) &
18335        "Analytical (upper) and numerical (lower) gradient of gamma"
18336       do i=4,nres
18337       do j=1,3
18338         dcji=dc(j,i-3)
18339         dc(j,i-3)=dcji+aincr
18340         call chainbuild_cart
18341         dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
18342             dc(j,i-3)=dcji
18343         dcji=dc(j,i-2)
18344         dc(j,i-2)=dcji+aincr
18345         call chainbuild_cart
18346         dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
18347         dc(j,i-2)=dcji
18348         dcji=dc(j,i-1)
18349         dc(j,i-1)=dc(j,i-1)+aincr
18350         call chainbuild_cart
18351         dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
18352         dc(j,i-1)=dcji
18353       enddo
18354 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
18355 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
18356 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
18357 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
18358 !el        write (iout,'(5x,3(3f10.5,5x))') &
18359 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
18360 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
18361 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
18362 !el        write (iout,*)
18363       enddo
18364 ! Check alpha gradient
18365       write (iout,*) &
18366        "Analytical (upper) and numerical (lower) gradient of alpha"
18367       do i=2,nres-1
18368        if(itype(i,1).ne.10) then
18369              do j=1,3
18370               dcji=dc(j,i-1)
18371                dc(j,i-1)=dcji+aincr
18372             call chainbuild_cart
18373             dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
18374              /aincr
18375               dc(j,i-1)=dcji
18376             dcji=dc(j,i)
18377             dc(j,i)=dcji+aincr
18378             call chainbuild_cart
18379             dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
18380              /aincr
18381             dc(j,i)=dcji
18382             dcji=dc(j,i+nres)
18383             dc(j,i+nres)=dc(j,i+nres)+aincr
18384             call chainbuild_cart
18385             dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
18386              /aincr
18387            dc(j,i+nres)=dcji
18388           enddo
18389         endif
18390 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
18391 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
18392 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
18393 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
18394 !el        write (iout,'(5x,3(3f10.5,5x))') &
18395 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
18396 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
18397 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
18398 !el        write (iout,*)
18399       enddo
18400 !     Check omega gradient
18401       write (iout,*) &
18402        "Analytical (upper) and numerical (lower) gradient of omega"
18403       do i=2,nres-1
18404        if(itype(i,1).ne.10) then
18405              do j=1,3
18406               dcji=dc(j,i-1)
18407                dc(j,i-1)=dcji+aincr
18408             call chainbuild_cart
18409             domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
18410              /aincr
18411               dc(j,i-1)=dcji
18412             dcji=dc(j,i)
18413             dc(j,i)=dcji+aincr
18414             call chainbuild_cart
18415             domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
18416              /aincr
18417             dc(j,i)=dcji
18418             dcji=dc(j,i+nres)
18419             dc(j,i+nres)=dc(j,i+nres)+aincr
18420             call chainbuild_cart
18421             domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
18422              /aincr
18423            dc(j,i+nres)=dcji
18424           enddo
18425         endif
18426 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
18427 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
18428 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
18429 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
18430 !el        write (iout,'(5x,3(3f10.5,5x))') &
18431 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
18432 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
18433 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
18434 !el        write (iout,*)
18435       enddo
18436       return
18437       end subroutine checkintcartgrad
18438 !-----------------------------------------------------------------------------
18439 ! q_measure.F
18440 !-----------------------------------------------------------------------------
18441       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
18442 !      implicit real*8 (a-h,o-z)
18443 !      include 'DIMENSIONS'
18444 !      include 'COMMON.IOUNITS'
18445 !      include 'COMMON.CHAIN'
18446 !      include 'COMMON.INTERACT'
18447 !      include 'COMMON.VAR'
18448       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
18449       integer :: kkk,nsep=3
18450       real(kind=8) :: qm      !dist,
18451       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
18452       logical :: lprn=.false.
18453       logical :: flag
18454 !      real(kind=8) :: sigm,x
18455
18456 !el      sigm(x)=0.25d0*x     ! local function
18457       qqmax=1.0d10
18458       do kkk=1,nperm
18459       qq = 0.0d0
18460       nl=0
18461        if(flag) then
18462       do il=seg1+nsep,seg2
18463         do jl=seg1,il-nsep
18464           nl=nl+1
18465           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
18466                    (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
18467                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18468           dij=dist(il,jl)
18469           qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
18470           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18471             nl=nl+1
18472             d0ijCM=dsqrt( &
18473                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18474                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18475                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18476             dijCM=dist(il+nres,jl+nres)
18477             qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
18478           endif
18479           qq = qq+qqij+qqijCM
18480         enddo
18481       enddo
18482       qq = qq/nl
18483       else
18484       do il=seg1,seg2
18485       if((seg3-il).lt.3) then
18486            secseg=il+3
18487       else
18488            secseg=seg3
18489       endif
18490         do jl=secseg,seg4
18491           nl=nl+1
18492           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18493                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18494                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18495           dij=dist(il,jl)
18496           qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
18497           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18498             nl=nl+1
18499             d0ijCM=dsqrt( &
18500                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18501                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18502                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18503             dijCM=dist(il+nres,jl+nres)
18504             qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
18505           endif
18506           qq = qq+qqij+qqijCM
18507         enddo
18508       enddo
18509       qq = qq/nl
18510       endif
18511       if (qqmax.le.qq) qqmax=qq
18512       enddo
18513       qwolynes=1.0d0-qqmax
18514       return
18515       end function qwolynes
18516 !-----------------------------------------------------------------------------
18517       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
18518 !      implicit real*8 (a-h,o-z)
18519 !      include 'DIMENSIONS'
18520 !      include 'COMMON.IOUNITS'
18521 !      include 'COMMON.CHAIN'
18522 !      include 'COMMON.INTERACT'
18523 !      include 'COMMON.VAR'
18524 !      include 'COMMON.MD'
18525       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
18526       integer :: nsep=3, kkk
18527 !el      real(kind=8) :: dist
18528       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
18529       logical :: lprn=.false.
18530       logical :: flag
18531       real(kind=8) :: sim,dd0,fac,ddqij
18532 !el      sigm(x)=0.25d0*x           ! local function
18533       do kkk=1,nperm
18534       do i=0,nres
18535       do j=1,3
18536         dqwol(j,i)=0.0d0
18537         dxqwol(j,i)=0.0d0
18538       enddo
18539       enddo
18540       nl=0
18541        if(flag) then
18542       do il=seg1+nsep,seg2
18543         do jl=seg1,il-nsep
18544           nl=nl+1
18545           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18546                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18547                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18548           dij=dist(il,jl)
18549           sim = 1.0d0/sigm(d0ij)
18550           sim = sim*sim
18551           dd0 = dij-d0ij
18552           fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
18553         do k=1,3
18554             ddqij = (c(k,il)-c(k,jl))*fac
18555             dqwol(k,il)=dqwol(k,il)+ddqij
18556             dqwol(k,jl)=dqwol(k,jl)-ddqij
18557           enddo
18558
18559           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18560             nl=nl+1
18561             d0ijCM=dsqrt( &
18562                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18563                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18564                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18565             dijCM=dist(il+nres,jl+nres)
18566             sim = 1.0d0/sigm(d0ijCM)
18567             sim = sim*sim
18568             dd0=dijCM-d0ijCM
18569             fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
18570             do k=1,3
18571             ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
18572             dxqwol(k,il)=dxqwol(k,il)+ddqij
18573             dxqwol(k,jl)=dxqwol(k,jl)-ddqij
18574             enddo
18575           endif
18576         enddo
18577       enddo
18578        else
18579       do il=seg1,seg2
18580       if((seg3-il).lt.3) then
18581            secseg=il+3
18582       else
18583            secseg=seg3
18584       endif
18585         do jl=secseg,seg4
18586           nl=nl+1
18587           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18588                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18589                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18590           dij=dist(il,jl)
18591           sim = 1.0d0/sigm(d0ij)
18592           sim = sim*sim
18593           dd0 = dij-d0ij
18594           fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
18595           do k=1,3
18596             ddqij = (c(k,il)-c(k,jl))*fac
18597             dqwol(k,il)=dqwol(k,il)+ddqij
18598             dqwol(k,jl)=dqwol(k,jl)-ddqij
18599           enddo
18600           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18601             nl=nl+1
18602             d0ijCM=dsqrt( &
18603                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18604                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18605                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18606             dijCM=dist(il+nres,jl+nres)
18607             sim = 1.0d0/sigm(d0ijCM)
18608             sim=sim*sim
18609             dd0 = dijCM-d0ijCM
18610             fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
18611             do k=1,3
18612              ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
18613              dxqwol(k,il)=dxqwol(k,il)+ddqij
18614              dxqwol(k,jl)=dxqwol(k,jl)-ddqij
18615             enddo
18616           endif
18617         enddo
18618       enddo
18619       endif
18620       enddo
18621        do i=0,nres
18622        do j=1,3
18623          dqwol(j,i)=dqwol(j,i)/nl
18624          dxqwol(j,i)=dxqwol(j,i)/nl
18625        enddo
18626        enddo
18627       return
18628       end subroutine qwolynes_prim
18629 !-----------------------------------------------------------------------------
18630       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
18631 !      implicit real*8 (a-h,o-z)
18632 !      include 'DIMENSIONS'
18633 !      include 'COMMON.IOUNITS'
18634 !      include 'COMMON.CHAIN'
18635 !      include 'COMMON.INTERACT'
18636 !      include 'COMMON.VAR'
18637       integer :: seg1,seg2,seg3,seg4
18638       logical :: flag
18639       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
18640       real(kind=8),dimension(3,0:2*nres) :: cdummy
18641       real(kind=8) :: q1,q2
18642       real(kind=8) :: delta=1.0d-10
18643       integer :: i,j
18644
18645       do i=0,nres
18646       do j=1,3
18647         q1=qwolynes(seg1,seg2,flag,seg3,seg4)
18648         cdummy(j,i)=c(j,i)
18649         c(j,i)=c(j,i)+delta
18650         q2=qwolynes(seg1,seg2,flag,seg3,seg4)
18651         qwolan(j,i)=(q2-q1)/delta
18652         c(j,i)=cdummy(j,i)
18653       enddo
18654       enddo
18655       do i=0,nres
18656       do j=1,3
18657         q1=qwolynes(seg1,seg2,flag,seg3,seg4)
18658         cdummy(j,i+nres)=c(j,i+nres)
18659         c(j,i+nres)=c(j,i+nres)+delta
18660         q2=qwolynes(seg1,seg2,flag,seg3,seg4)
18661         qwolxan(j,i)=(q2-q1)/delta
18662         c(j,i+nres)=cdummy(j,i+nres)
18663       enddo
18664       enddo
18665 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
18666 !      do i=0,nct
18667 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
18668 !      enddo
18669 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
18670 !      do i=0,nct
18671 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
18672 !      enddo
18673       return
18674       end subroutine qwol_num
18675 !-----------------------------------------------------------------------------
18676       subroutine EconstrQ
18677 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
18678 !      implicit real*8 (a-h,o-z)
18679 !      include 'DIMENSIONS'
18680 !      include 'COMMON.CONTROL'
18681 !      include 'COMMON.VAR'
18682 !      include 'COMMON.MD'
18683       use MD_data
18684 !#ifndef LANG0
18685 !      include 'COMMON.LANGEVIN'
18686 !#else
18687 !      include 'COMMON.LANGEVIN.lang0'
18688 !#endif
18689 !      include 'COMMON.CHAIN'
18690 !      include 'COMMON.DERIV'
18691 !      include 'COMMON.GEO'
18692 !      include 'COMMON.LOCAL'
18693 !      include 'COMMON.INTERACT'
18694 !      include 'COMMON.IOUNITS'
18695 !      include 'COMMON.NAMES'
18696 !      include 'COMMON.TIME1'
18697       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
18698       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
18699                duconst,duxconst
18700       integer :: kstart,kend,lstart,lend,idummy
18701       real(kind=8) :: delta=1.0d-7
18702       integer :: i,j,k,ii
18703       do i=0,nres
18704        do j=1,3
18705           duconst(j,i)=0.0d0
18706           dudconst(j,i)=0.0d0
18707           duxconst(j,i)=0.0d0
18708           dudxconst(j,i)=0.0d0
18709        enddo
18710       enddo
18711       Uconst=0.0d0
18712       do i=1,nfrag
18713        qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18714          idummy,idummy)
18715        Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
18716 ! Calculating the derivatives of Constraint energy with respect to Q
18717        Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
18718          qinfrag(i,iset))
18719 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
18720 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
18721 !         hmnum=(hm2-hm1)/delta
18722 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
18723 !     &   qinfrag(i,iset))
18724 !         write(iout,*) "harmonicnum frag", hmnum
18725 ! Calculating the derivatives of Q with respect to cartesian coordinates
18726        call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18727         idummy,idummy)
18728 !         write(iout,*) "dqwol "
18729 !         do ii=1,nres
18730 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18731 !         enddo
18732 !         write(iout,*) "dxqwol "
18733 !         do ii=1,nres
18734 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18735 !         enddo
18736 ! Calculating numerical gradients of dU/dQi and dQi/dxi
18737 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
18738 !     &  ,idummy,idummy)
18739 !  The gradients of Uconst in Cs
18740        do ii=0,nres
18741           do j=1,3
18742              duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
18743              dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
18744           enddo
18745        enddo
18746       enddo
18747       do i=1,npair
18748        kstart=ifrag(1,ipair(1,i,iset),iset)
18749        kend=ifrag(2,ipair(1,i,iset),iset)
18750        lstart=ifrag(1,ipair(2,i,iset),iset)
18751        lend=ifrag(2,ipair(2,i,iset),iset)
18752        qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
18753        Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
18754 !  Calculating dU/dQ
18755        Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
18756 !         hm1=harmonic(qpair(i),qinpair(i,iset))
18757 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
18758 !         hmnum=(hm2-hm1)/delta
18759 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
18760 !     &   qinpair(i,iset))
18761 !         write(iout,*) "harmonicnum pair ", hmnum
18762 ! Calculating dQ/dXi
18763        call qwolynes_prim(kstart,kend,.false.,&
18764         lstart,lend)
18765 !         write(iout,*) "dqwol "
18766 !         do ii=1,nres
18767 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18768 !         enddo
18769 !         write(iout,*) "dxqwol "
18770 !         do ii=1,nres
18771 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18772 !        enddo
18773 ! Calculating numerical gradients
18774 !        call qwol_num(kstart,kend,.false.
18775 !     &  ,lstart,lend)
18776 ! The gradients of Uconst in Cs
18777        do ii=0,nres
18778           do j=1,3
18779              duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
18780              dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
18781           enddo
18782        enddo
18783       enddo
18784 !      write(iout,*) "Uconst inside subroutine ", Uconst
18785 ! Transforming the gradients from Cs to dCs for the backbone
18786       do i=0,nres
18787        do j=i+1,nres
18788          do k=1,3
18789            dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
18790          enddo
18791        enddo
18792       enddo
18793 !  Transforming the gradients from Cs to dCs for the side chains
18794       do i=1,nres
18795        do j=1,3
18796          dudxconst(j,i)=duxconst(j,i)
18797        enddo
18798       enddo
18799 !      write(iout,*) "dU/ddc backbone "
18800 !       do ii=0,nres
18801 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
18802 !      enddo
18803 !      write(iout,*) "dU/ddX side chain "
18804 !      do ii=1,nres
18805 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
18806 !      enddo
18807 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
18808 !      call dEconstrQ_num
18809       return
18810       end subroutine EconstrQ
18811 !-----------------------------------------------------------------------------
18812       subroutine dEconstrQ_num
18813 ! Calculating numerical dUconst/ddc and dUconst/ddx
18814 !      implicit real*8 (a-h,o-z)
18815 !      include 'DIMENSIONS'
18816 !      include 'COMMON.CONTROL'
18817 !      include 'COMMON.VAR'
18818 !      include 'COMMON.MD'
18819       use MD_data
18820 !#ifndef LANG0
18821 !      include 'COMMON.LANGEVIN'
18822 !#else
18823 !      include 'COMMON.LANGEVIN.lang0'
18824 !#endif
18825 !      include 'COMMON.CHAIN'
18826 !      include 'COMMON.DERIV'
18827 !      include 'COMMON.GEO'
18828 !      include 'COMMON.LOCAL'
18829 !      include 'COMMON.INTERACT'
18830 !      include 'COMMON.IOUNITS'
18831 !      include 'COMMON.NAMES'
18832 !      include 'COMMON.TIME1'
18833       real(kind=8) :: uzap1,uzap2
18834       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
18835       integer :: kstart,kend,lstart,lend,idummy
18836       real(kind=8) :: delta=1.0d-7
18837 !el local variables
18838       integer :: i,ii,j
18839 !     real(kind=8) ::
18840 !     For the backbone
18841       do i=0,nres-1
18842        do j=1,3
18843           dUcartan(j,i)=0.0d0
18844           cdummy(j,i)=dc(j,i)
18845           dc(j,i)=dc(j,i)+delta
18846           call chainbuild_cart
18847         uzap2=0.0d0
18848           do ii=1,nfrag
18849            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18850             idummy,idummy)
18851              uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18852             qinfrag(ii,iset))
18853           enddo
18854           do ii=1,npair
18855              kstart=ifrag(1,ipair(1,ii,iset),iset)
18856              kend=ifrag(2,ipair(1,ii,iset),iset)
18857              lstart=ifrag(1,ipair(2,ii,iset),iset)
18858              lend=ifrag(2,ipair(2,ii,iset),iset)
18859              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18860              uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18861              qinpair(ii,iset))
18862           enddo
18863           dc(j,i)=cdummy(j,i)
18864           call chainbuild_cart
18865           uzap1=0.0d0
18866            do ii=1,nfrag
18867            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18868             idummy,idummy)
18869              uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18870             qinfrag(ii,iset))
18871           enddo
18872           do ii=1,npair
18873              kstart=ifrag(1,ipair(1,ii,iset),iset)
18874              kend=ifrag(2,ipair(1,ii,iset),iset)
18875              lstart=ifrag(1,ipair(2,ii,iset),iset)
18876              lend=ifrag(2,ipair(2,ii,iset),iset)
18877              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18878              uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18879             qinpair(ii,iset))
18880           enddo
18881           ducartan(j,i)=(uzap2-uzap1)/(delta)
18882        enddo
18883       enddo
18884 ! Calculating numerical gradients for dU/ddx
18885       do i=0,nres-1
18886        duxcartan(j,i)=0.0d0
18887        do j=1,3
18888           cdummy(j,i)=dc(j,i+nres)
18889           dc(j,i+nres)=dc(j,i+nres)+delta
18890           call chainbuild_cart
18891         uzap2=0.0d0
18892           do ii=1,nfrag
18893            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18894             idummy,idummy)
18895              uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18896             qinfrag(ii,iset))
18897           enddo
18898           do ii=1,npair
18899              kstart=ifrag(1,ipair(1,ii,iset),iset)
18900              kend=ifrag(2,ipair(1,ii,iset),iset)
18901              lstart=ifrag(1,ipair(2,ii,iset),iset)
18902              lend=ifrag(2,ipair(2,ii,iset),iset)
18903              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18904              uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18905             qinpair(ii,iset))
18906           enddo
18907           dc(j,i+nres)=cdummy(j,i)
18908           call chainbuild_cart
18909           uzap1=0.0d0
18910            do ii=1,nfrag
18911              qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
18912             ifrag(2,ii,iset),.true.,idummy,idummy)
18913              uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18914             qinfrag(ii,iset))
18915           enddo
18916           do ii=1,npair
18917              kstart=ifrag(1,ipair(1,ii,iset),iset)
18918              kend=ifrag(2,ipair(1,ii,iset),iset)
18919              lstart=ifrag(1,ipair(2,ii,iset),iset)
18920              lend=ifrag(2,ipair(2,ii,iset),iset)
18921              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18922              uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18923             qinpair(ii,iset))
18924           enddo
18925           duxcartan(j,i)=(uzap2-uzap1)/(delta)
18926        enddo
18927       enddo
18928       write(iout,*) "Numerical dUconst/ddc backbone "
18929       do ii=0,nres
18930       write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
18931       enddo
18932 !      write(iout,*) "Numerical dUconst/ddx side-chain "
18933 !      do ii=1,nres
18934 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
18935 !      enddo
18936       return
18937       end subroutine dEconstrQ_num
18938 !-----------------------------------------------------------------------------
18939 ! ssMD.F
18940 !-----------------------------------------------------------------------------
18941       subroutine check_energies
18942
18943 !      use random, only: ran_number
18944
18945 !      implicit none
18946 !     Includes
18947 !      include 'DIMENSIONS'
18948 !      include 'COMMON.CHAIN'
18949 !      include 'COMMON.VAR'
18950 !      include 'COMMON.IOUNITS'
18951 !      include 'COMMON.SBRIDGE'
18952 !      include 'COMMON.LOCAL'
18953 !      include 'COMMON.GEO'
18954
18955 !     External functions
18956 !EL      double precision ran_number
18957 !EL      external ran_number
18958
18959 !     Local variables
18960       integer :: i,j,k,l,lmax,p,pmax
18961       real(kind=8) :: rmin,rmax
18962       real(kind=8) :: eij
18963
18964       real(kind=8) :: d
18965       real(kind=8) :: wi,rij,tj,pj
18966 !      return
18967
18968       i=5
18969       j=14
18970
18971       d=dsc(1)
18972       rmin=2.0D0
18973       rmax=12.0D0
18974
18975       lmax=10000
18976       pmax=1
18977
18978       do k=1,3
18979       c(k,i)=0.0D0
18980       c(k,j)=0.0D0
18981       c(k,nres+i)=0.0D0
18982       c(k,nres+j)=0.0D0
18983       enddo
18984
18985       do l=1,lmax
18986
18987 !t        wi=ran_number(0.0D0,pi)
18988 !        wi=ran_number(0.0D0,pi/6.0D0)
18989 !        wi=0.0D0
18990 !t        tj=ran_number(0.0D0,pi)
18991 !t        pj=ran_number(0.0D0,pi)
18992 !        pj=ran_number(0.0D0,pi/6.0D0)
18993 !        pj=0.0D0
18994
18995       do p=1,pmax
18996 !t           rij=ran_number(rmin,rmax)
18997
18998          c(1,j)=d*sin(pj)*cos(tj)
18999          c(2,j)=d*sin(pj)*sin(tj)
19000          c(3,j)=d*cos(pj)
19001
19002          c(3,nres+i)=-rij
19003
19004          c(1,i)=d*sin(wi)
19005          c(3,i)=-rij-d*cos(wi)
19006
19007          do k=1,3
19008             dc(k,nres+i)=c(k,nres+i)-c(k,i)
19009             dc_norm(k,nres+i)=dc(k,nres+i)/d
19010             dc(k,nres+j)=c(k,nres+j)-c(k,j)
19011             dc_norm(k,nres+j)=dc(k,nres+j)/d
19012          enddo
19013
19014          call dyn_ssbond_ene(i,j,eij)
19015       enddo
19016       enddo
19017       call exit(1)
19018       return
19019       end subroutine check_energies
19020 !-----------------------------------------------------------------------------
19021       subroutine dyn_ssbond_ene(resi,resj,eij)
19022 !      implicit none
19023 !      Includes
19024       use calc_data
19025       use comm_sschecks
19026 !      include 'DIMENSIONS'
19027 !      include 'COMMON.SBRIDGE'
19028 !      include 'COMMON.CHAIN'
19029 !      include 'COMMON.DERIV'
19030 !      include 'COMMON.LOCAL'
19031 !      include 'COMMON.INTERACT'
19032 !      include 'COMMON.VAR'
19033 !      include 'COMMON.IOUNITS'
19034 !      include 'COMMON.CALC'
19035 #ifndef CLUST
19036 #ifndef WHAM
19037        use MD_data
19038 !      include 'COMMON.MD'
19039 !      use MD, only: totT,t_bath
19040 #endif
19041 #endif
19042 !     External functions
19043 !EL      double precision h_base
19044 !EL      external h_base
19045
19046 !     Input arguments
19047       integer :: resi,resj
19048
19049 !     Output arguments
19050       real(kind=8) :: eij
19051
19052 !     Local variables
19053       logical :: havebond
19054       integer itypi,itypj
19055       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
19056       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
19057       real(kind=8),dimension(3) :: dcosom1,dcosom2
19058       real(kind=8) :: ed
19059       real(kind=8) :: pom1,pom2
19060       real(kind=8) :: ljA,ljB,ljXs
19061       real(kind=8),dimension(1:3) :: d_ljB
19062       real(kind=8) :: ssA,ssB,ssC,ssXs
19063       real(kind=8) :: ssxm,ljxm,ssm,ljm
19064       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
19065       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
19066       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
19067 !-------FIRST METHOD
19068       real(kind=8) :: xm
19069       real(kind=8),dimension(1:3) :: d_xm
19070 !-------END FIRST METHOD
19071 !-------SECOND METHOD
19072 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
19073 !-------END SECOND METHOD
19074
19075 !-------TESTING CODE
19076 !el      logical :: checkstop,transgrad
19077 !el      common /sschecks/ checkstop,transgrad
19078
19079       integer :: icheck,nicheck,jcheck,njcheck
19080       real(kind=8),dimension(-1:1) :: echeck
19081       real(kind=8) :: deps,ssx0,ljx0
19082 !-------END TESTING CODE
19083
19084       eij=0.0d0
19085       i=resi
19086       j=resj
19087
19088 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
19089 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
19090
19091       itypi=itype(i,1)
19092       dxi=dc_norm(1,nres+i)
19093       dyi=dc_norm(2,nres+i)
19094       dzi=dc_norm(3,nres+i)
19095       dsci_inv=vbld_inv(i+nres)
19096
19097       itypj=itype(j,1)
19098       xj=c(1,nres+j)-c(1,nres+i)
19099       yj=c(2,nres+j)-c(2,nres+i)
19100       zj=c(3,nres+j)-c(3,nres+i)
19101       dxj=dc_norm(1,nres+j)
19102       dyj=dc_norm(2,nres+j)
19103       dzj=dc_norm(3,nres+j)
19104       dscj_inv=vbld_inv(j+nres)
19105
19106       chi1=chi(itypi,itypj)
19107       chi2=chi(itypj,itypi)
19108       chi12=chi1*chi2
19109       chip1=chip(itypi)
19110       chip2=chip(itypj)
19111       chip12=chip1*chip2
19112       alf1=alp(itypi)
19113       alf2=alp(itypj)
19114       alf12=0.5D0*(alf1+alf2)
19115
19116       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
19117       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
19118 !     The following are set in sc_angular
19119 !      erij(1)=xj*rij
19120 !      erij(2)=yj*rij
19121 !      erij(3)=zj*rij
19122 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
19123 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
19124 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
19125       call sc_angular
19126       rij=1.0D0/rij  ! Reset this so it makes sense
19127
19128       sig0ij=sigma(itypi,itypj)
19129       sig=sig0ij*dsqrt(1.0D0/sigsq)
19130
19131       ljXs=sig-sig0ij
19132       ljA=eps1*eps2rt**2*eps3rt**2
19133       ljB=ljA*bb_aq(itypi,itypj)
19134       ljA=ljA*aa_aq(itypi,itypj)
19135       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
19136
19137       ssXs=d0cm
19138       deltat1=1.0d0-om1
19139       deltat2=1.0d0+om2
19140       deltat12=om2-om1+2.0d0
19141       cosphi=om12-om1*om2
19142       ssA=akcm
19143       ssB=akct*deltat12
19144       ssC=ss_depth &
19145          +akth*(deltat1*deltat1+deltat2*deltat2) &
19146          +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
19147       ssxm=ssXs-0.5D0*ssB/ssA
19148
19149 !-------TESTING CODE
19150 !$$$c     Some extra output
19151 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
19152 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
19153 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
19154 !$$$      if (ssx0.gt.0.0d0) then
19155 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
19156 !$$$      else
19157 !$$$        ssx0=ssxm
19158 !$$$      endif
19159 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
19160 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
19161 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
19162 !$$$      return
19163 !-------END TESTING CODE
19164
19165 !-------TESTING CODE
19166 !     Stop and plot energy and derivative as a function of distance
19167       if (checkstop) then
19168       ssm=ssC-0.25D0*ssB*ssB/ssA
19169       ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
19170       if (ssm.lt.ljm .and. &
19171            dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
19172         nicheck=1000
19173         njcheck=1
19174         deps=0.5d-7
19175       else
19176         checkstop=.false.
19177       endif
19178       endif
19179       if (.not.checkstop) then
19180       nicheck=0
19181       njcheck=-1
19182       endif
19183
19184       do icheck=0,nicheck
19185       do jcheck=-1,njcheck
19186       if (checkstop) rij=(ssxm-1.0d0)+ &
19187            ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
19188 !-------END TESTING CODE
19189
19190       if (rij.gt.ljxm) then
19191       havebond=.false.
19192       ljd=rij-ljXs
19193       fac=(1.0D0/ljd)**expon
19194       e1=fac*fac*aa_aq(itypi,itypj)
19195       e2=fac*bb_aq(itypi,itypj)
19196       eij=eps1*eps2rt*eps3rt*(e1+e2)
19197       eps2der=eij*eps3rt
19198       eps3der=eij*eps2rt
19199       eij=eij*eps2rt*eps3rt
19200
19201       sigder=-sig/sigsq
19202       e1=e1*eps1*eps2rt**2*eps3rt**2
19203       ed=-expon*(e1+eij)/ljd
19204       sigder=ed*sigder
19205       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
19206       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
19207       eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
19208            -2.0D0*alf12*eps3der+sigder*sigsq_om12
19209       else if (rij.lt.ssxm) then
19210       havebond=.true.
19211       ssd=rij-ssXs
19212       eij=ssA*ssd*ssd+ssB*ssd+ssC
19213
19214       ed=2*akcm*ssd+akct*deltat12
19215       pom1=akct*ssd
19216       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
19217       eom1=-2*akth*deltat1-pom1-om2*pom2
19218       eom2= 2*akth*deltat2+pom1-om1*pom2
19219       eom12=pom2
19220       else
19221       omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
19222
19223       d_ssxm(1)=0.5D0*akct/ssA
19224       d_ssxm(2)=-d_ssxm(1)
19225       d_ssxm(3)=0.0D0
19226
19227       d_ljxm(1)=sig0ij/sqrt(sigsq**3)
19228       d_ljxm(2)=d_ljxm(1)*sigsq_om2
19229       d_ljxm(3)=d_ljxm(1)*sigsq_om12
19230       d_ljxm(1)=d_ljxm(1)*sigsq_om1
19231
19232 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
19233       xm=0.5d0*(ssxm+ljxm)
19234       do k=1,3
19235         d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
19236       enddo
19237       if (rij.lt.xm) then
19238         havebond=.true.
19239         ssm=ssC-0.25D0*ssB*ssB/ssA
19240         d_ssm(1)=0.5D0*akct*ssB/ssA
19241         d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
19242         d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
19243         d_ssm(3)=omega
19244         f1=(rij-xm)/(ssxm-xm)
19245         f2=(rij-ssxm)/(xm-ssxm)
19246         h1=h_base(f1,hd1)
19247         h2=h_base(f2,hd2)
19248         eij=ssm*h1+Ht*h2
19249         delta_inv=1.0d0/(xm-ssxm)
19250         deltasq_inv=delta_inv*delta_inv
19251         fac=ssm*hd1-Ht*hd2
19252         fac1=deltasq_inv*fac*(xm-rij)
19253         fac2=deltasq_inv*fac*(rij-ssxm)
19254         ed=delta_inv*(Ht*hd2-ssm*hd1)
19255         eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
19256         eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
19257         eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
19258       else
19259         havebond=.false.
19260         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
19261         d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
19262         d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
19263         d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
19264              alf12/eps3rt)
19265         d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
19266         f1=(rij-ljxm)/(xm-ljxm)
19267         f2=(rij-xm)/(ljxm-xm)
19268         h1=h_base(f1,hd1)
19269         h2=h_base(f2,hd2)
19270         eij=Ht*h1+ljm*h2
19271         delta_inv=1.0d0/(ljxm-xm)
19272         deltasq_inv=delta_inv*delta_inv
19273         fac=Ht*hd1-ljm*hd2
19274         fac1=deltasq_inv*fac*(ljxm-rij)
19275         fac2=deltasq_inv*fac*(rij-xm)
19276         ed=delta_inv*(ljm*hd2-Ht*hd1)
19277         eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
19278         eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
19279         eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
19280       endif
19281 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
19282
19283 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
19284 !$$$        ssd=rij-ssXs
19285 !$$$        ljd=rij-ljXs
19286 !$$$        fac1=rij-ljxm
19287 !$$$        fac2=rij-ssxm
19288 !$$$
19289 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
19290 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
19291 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
19292 !$$$
19293 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
19294 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
19295 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
19296 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
19297 !$$$        d_ssm(3)=omega
19298 !$$$
19299 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
19300 !$$$        do k=1,3
19301 !$$$          d_ljm(k)=ljm*d_ljB(k)
19302 !$$$        enddo
19303 !$$$        ljm=ljm*ljB
19304 !$$$
19305 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
19306 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
19307 !$$$        d_ss(2)=akct*ssd
19308 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
19309 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
19310 !$$$        d_ss(3)=omega
19311 !$$$
19312 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
19313 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
19314 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
19315 !$$$        do k=1,3
19316 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
19317 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
19318 !$$$        enddo
19319 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
19320 !$$$
19321 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
19322 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
19323 !$$$        h1=h_base(f1,hd1)
19324 !$$$        h2=h_base(f2,hd2)
19325 !$$$        eij=ss*h1+ljf*h2
19326 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
19327 !$$$        deltasq_inv=delta_inv*delta_inv
19328 !$$$        fac=ljf*hd2-ss*hd1
19329 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
19330 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
19331 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
19332 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
19333 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
19334 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
19335 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
19336 !$$$
19337 !$$$        havebond=.false.
19338 !$$$        if (ed.gt.0.0d0) havebond=.true.
19339 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
19340
19341       endif
19342
19343       if (havebond) then
19344 !#ifndef CLUST
19345 !#ifndef WHAM
19346 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
19347 !          write(iout,'(a15,f12.2,f8.1,2i5)')
19348 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
19349 !        endif
19350 !#endif
19351 !#endif
19352       dyn_ssbond_ij(i,j)=eij
19353       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
19354       dyn_ssbond_ij(i,j)=1.0d300
19355 !#ifndef CLUST
19356 !#ifndef WHAM
19357 !        write(iout,'(a15,f12.2,f8.1,2i5)')
19358 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
19359 !#endif
19360 !#endif
19361       endif
19362
19363 !-------TESTING CODE
19364 !el      if (checkstop) then
19365       if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
19366            "CHECKSTOP",rij,eij,ed
19367       echeck(jcheck)=eij
19368 !el      endif
19369       enddo
19370       if (checkstop) then
19371       write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
19372       endif
19373       enddo
19374       if (checkstop) then
19375       transgrad=.true.
19376       checkstop=.false.
19377       endif
19378 !-------END TESTING CODE
19379
19380       do k=1,3
19381       dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
19382       dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
19383       enddo
19384       do k=1,3
19385       gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
19386       enddo
19387       do k=1,3
19388       gvdwx(k,i)=gvdwx(k,i)-gg(k) &
19389            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
19390            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
19391       gvdwx(k,j)=gvdwx(k,j)+gg(k) &
19392            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
19393            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
19394       enddo
19395 !grad      do k=i,j-1
19396 !grad        do l=1,3
19397 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
19398 !grad        enddo
19399 !grad      enddo
19400
19401       do l=1,3
19402       gvdwc(l,i)=gvdwc(l,i)-gg(l)
19403       gvdwc(l,j)=gvdwc(l,j)+gg(l)
19404       enddo
19405
19406       return
19407       end subroutine dyn_ssbond_ene
19408 !--------------------------------------------------------------------------
19409        subroutine triple_ssbond_ene(resi,resj,resk,eij)
19410 !      implicit none
19411 !      Includes
19412       use calc_data
19413       use comm_sschecks
19414 !      include 'DIMENSIONS'
19415 !      include 'COMMON.SBRIDGE'
19416 !      include 'COMMON.CHAIN'
19417 !      include 'COMMON.DERIV'
19418 !      include 'COMMON.LOCAL'
19419 !      include 'COMMON.INTERACT'
19420 !      include 'COMMON.VAR'
19421 !      include 'COMMON.IOUNITS'
19422 !      include 'COMMON.CALC'
19423 #ifndef CLUST
19424 #ifndef WHAM
19425        use MD_data
19426 !      include 'COMMON.MD'
19427 !      use MD, only: totT,t_bath
19428 #endif
19429 #endif
19430       double precision h_base
19431       external h_base
19432
19433 !c     Input arguments
19434       integer resi,resj,resk,m,itypi,itypj,itypk
19435
19436 !c     Output arguments
19437       double precision eij,eij1,eij2,eij3
19438
19439 !c     Local variables
19440       logical havebond
19441 !c      integer itypi,itypj,k,l
19442       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
19443       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
19444       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
19445       double precision sig0ij,ljd,sig,fac,e1,e2
19446       double precision dcosom1(3),dcosom2(3),ed
19447       double precision pom1,pom2
19448       double precision ljA,ljB,ljXs
19449       double precision d_ljB(1:3)
19450       double precision ssA,ssB,ssC,ssXs
19451       double precision ssxm,ljxm,ssm,ljm
19452       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
19453       eij=0.0
19454       if (dtriss.eq.0) return
19455       i=resi
19456       j=resj
19457       k=resk
19458 !C      write(iout,*) resi,resj,resk
19459       itypi=itype(i,1)
19460       dxi=dc_norm(1,nres+i)
19461       dyi=dc_norm(2,nres+i)
19462       dzi=dc_norm(3,nres+i)
19463       dsci_inv=vbld_inv(i+nres)
19464       xi=c(1,nres+i)
19465       yi=c(2,nres+i)
19466       zi=c(3,nres+i)
19467       call to_box(xi,yi,zi)
19468       itypj=itype(j,1)
19469       xj=c(1,nres+j)
19470       yj=c(2,nres+j)
19471       zj=c(3,nres+j)
19472       call to_box(xj,yj,zj)
19473       dxj=dc_norm(1,nres+j)
19474       dyj=dc_norm(2,nres+j)
19475       dzj=dc_norm(3,nres+j)
19476       dscj_inv=vbld_inv(j+nres)
19477       itypk=itype(k,1)
19478       xk=c(1,nres+k)
19479       yk=c(2,nres+k)
19480       zk=c(3,nres+k)
19481        call to_box(xk,yk,zk)
19482       dxk=dc_norm(1,nres+k)
19483       dyk=dc_norm(2,nres+k)
19484       dzk=dc_norm(3,nres+k)
19485       dscj_inv=vbld_inv(k+nres)
19486       xij=xj-xi
19487       xik=xk-xi
19488       xjk=xk-xj
19489       yij=yj-yi
19490       yik=yk-yi
19491       yjk=yk-yj
19492       zij=zj-zi
19493       zik=zk-zi
19494       zjk=zk-zj
19495       rrij=(xij*xij+yij*yij+zij*zij)
19496       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
19497       rrik=(xik*xik+yik*yik+zik*zik)
19498       rik=dsqrt(rrik)
19499       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
19500       rjk=dsqrt(rrjk)
19501 !C there are three combination of distances for each trisulfide bonds
19502 !C The first case the ith atom is the center
19503 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
19504 !C distance y is second distance the a,b,c,d are parameters derived for
19505 !C this problem d parameter was set as a penalty currenlty set to 1.
19506       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
19507       eij1=0.0d0
19508       else
19509       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
19510       endif
19511 !C second case jth atom is center
19512       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
19513       eij2=0.0d0
19514       else
19515       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
19516       endif
19517 !C the third case kth atom is the center
19518       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
19519       eij3=0.0d0
19520       else
19521       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
19522       endif
19523 !C      eij2=0.0
19524 !C      eij3=0.0
19525 !C      eij1=0.0
19526       eij=eij1+eij2+eij3
19527 !C      write(iout,*)i,j,k,eij
19528 !C The energy penalty calculated now time for the gradient part
19529 !C derivative over rij
19530       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
19531       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
19532           gg(1)=xij*fac/rij
19533           gg(2)=yij*fac/rij
19534           gg(3)=zij*fac/rij
19535       do m=1,3
19536       gvdwx(m,i)=gvdwx(m,i)-gg(m)
19537       gvdwx(m,j)=gvdwx(m,j)+gg(m)
19538       enddo
19539
19540       do l=1,3
19541       gvdwc(l,i)=gvdwc(l,i)-gg(l)
19542       gvdwc(l,j)=gvdwc(l,j)+gg(l)
19543       enddo
19544 !C now derivative over rik
19545       fac=-eij1**2/dtriss* &
19546       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
19547       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
19548           gg(1)=xik*fac/rik
19549           gg(2)=yik*fac/rik
19550           gg(3)=zik*fac/rik
19551       do m=1,3
19552       gvdwx(m,i)=gvdwx(m,i)-gg(m)
19553       gvdwx(m,k)=gvdwx(m,k)+gg(m)
19554       enddo
19555       do l=1,3
19556       gvdwc(l,i)=gvdwc(l,i)-gg(l)
19557       gvdwc(l,k)=gvdwc(l,k)+gg(l)
19558       enddo
19559 !C now derivative over rjk
19560       fac=-eij2**2/dtriss* &
19561       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
19562       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
19563           gg(1)=xjk*fac/rjk
19564           gg(2)=yjk*fac/rjk
19565           gg(3)=zjk*fac/rjk
19566       do m=1,3
19567       gvdwx(m,j)=gvdwx(m,j)-gg(m)
19568       gvdwx(m,k)=gvdwx(m,k)+gg(m)
19569       enddo
19570       do l=1,3
19571       gvdwc(l,j)=gvdwc(l,j)-gg(l)
19572       gvdwc(l,k)=gvdwc(l,k)+gg(l)
19573       enddo
19574       return
19575       end subroutine triple_ssbond_ene
19576
19577
19578
19579 !-----------------------------------------------------------------------------
19580       real(kind=8) function h_base(x,deriv)
19581 !     A smooth function going 0->1 in range [0,1]
19582 !     It should NOT be called outside range [0,1], it will not work there.
19583       implicit none
19584
19585 !     Input arguments
19586       real(kind=8) :: x
19587
19588 !     Output arguments
19589       real(kind=8) :: deriv
19590
19591 !     Local variables
19592       real(kind=8) :: xsq
19593
19594
19595 !     Two parabolas put together.  First derivative zero at extrema
19596 !$$$      if (x.lt.0.5D0) then
19597 !$$$        h_base=2.0D0*x*x
19598 !$$$        deriv=4.0D0*x
19599 !$$$      else
19600 !$$$        deriv=1.0D0-x
19601 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
19602 !$$$        deriv=4.0D0*deriv
19603 !$$$      endif
19604
19605 !     Third degree polynomial.  First derivative zero at extrema
19606       h_base=x*x*(3.0d0-2.0d0*x)
19607       deriv=6.0d0*x*(1.0d0-x)
19608
19609 !     Fifth degree polynomial.  First and second derivatives zero at extrema
19610 !$$$      xsq=x*x
19611 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
19612 !$$$      deriv=x-1.0d0
19613 !$$$      deriv=deriv*deriv
19614 !$$$      deriv=30.0d0*xsq*deriv
19615
19616       return
19617       end function h_base
19618 !-----------------------------------------------------------------------------
19619       subroutine dyn_set_nss
19620 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
19621 !      implicit none
19622       use MD_data, only: totT,t_bath
19623 !     Includes
19624 !      include 'DIMENSIONS'
19625 #ifdef MPI
19626       include "mpif.h"
19627 #endif
19628 !      include 'COMMON.SBRIDGE'
19629 !      include 'COMMON.CHAIN'
19630 !      include 'COMMON.IOUNITS'
19631 !      include 'COMMON.SETUP'
19632 !      include 'COMMON.MD'
19633 !     Local variables
19634       real(kind=8) :: emin
19635       integer :: i,j,imin,ierr
19636       integer :: diff,allnss,newnss
19637       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
19638             newihpb,newjhpb
19639       logical :: found
19640       integer,dimension(0:nfgtasks) :: i_newnss
19641       integer,dimension(0:nfgtasks) :: displ
19642       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
19643       integer :: g_newnss
19644
19645       allnss=0
19646       do i=1,nres-1
19647       do j=i+1,nres
19648         if (dyn_ssbond_ij(i,j).lt.1.0d300) then
19649           allnss=allnss+1
19650           allflag(allnss)=0
19651           allihpb(allnss)=i
19652           alljhpb(allnss)=j
19653         endif
19654       enddo
19655       enddo
19656
19657 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19658
19659  1    emin=1.0d300
19660       do i=1,allnss
19661       if (allflag(i).eq.0 .and. &
19662            dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
19663         emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
19664         imin=i
19665       endif
19666       enddo
19667       if (emin.lt.1.0d300) then
19668       allflag(imin)=1
19669       do i=1,allnss
19670         if (allflag(i).eq.0 .and. &
19671              (allihpb(i).eq.allihpb(imin) .or. &
19672              alljhpb(i).eq.allihpb(imin) .or. &
19673              allihpb(i).eq.alljhpb(imin) .or. &
19674              alljhpb(i).eq.alljhpb(imin))) then
19675           allflag(i)=-1
19676         endif
19677       enddo
19678       goto 1
19679       endif
19680
19681 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19682
19683       newnss=0
19684       do i=1,allnss
19685       if (allflag(i).eq.1) then
19686         newnss=newnss+1
19687         newihpb(newnss)=allihpb(i)
19688         newjhpb(newnss)=alljhpb(i)
19689       endif
19690       enddo
19691
19692 #ifdef MPI
19693       if (nfgtasks.gt.1)then
19694
19695       call MPI_Reduce(newnss,g_newnss,1,&
19696         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
19697       call MPI_Gather(newnss,1,MPI_INTEGER,&
19698                   i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
19699       displ(0)=0
19700       do i=1,nfgtasks-1,1
19701         displ(i)=i_newnss(i-1)+displ(i-1)
19702       enddo
19703       call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
19704                    g_newihpb,i_newnss,displ,MPI_INTEGER,&
19705                    king,FG_COMM,IERR)
19706       call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
19707                    g_newjhpb,i_newnss,displ,MPI_INTEGER,&
19708                    king,FG_COMM,IERR)
19709       if(fg_rank.eq.0) then
19710 !         print *,'g_newnss',g_newnss
19711 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
19712 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
19713        newnss=g_newnss
19714        do i=1,newnss
19715         newihpb(i)=g_newihpb(i)
19716         newjhpb(i)=g_newjhpb(i)
19717        enddo
19718       endif
19719       endif
19720 #endif
19721
19722       diff=newnss-nss
19723
19724 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
19725 !       print *,newnss,nss,maxdim
19726       do i=1,nss
19727       found=.false.
19728 !        print *,newnss
19729       do j=1,newnss
19730 !!          print *,j
19731         if (idssb(i).eq.newihpb(j) .and. &
19732              jdssb(i).eq.newjhpb(j)) found=.true.
19733       enddo
19734 #ifndef CLUST
19735 #ifndef WHAM
19736 !        write(iout,*) "found",found,i,j
19737       if (.not.found.and.fg_rank.eq.0) &
19738           write(iout,'(a15,f12.2,f8.1,2i5)') &
19739            "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
19740 #endif
19741 #endif
19742       enddo
19743
19744       do i=1,newnss
19745       found=.false.
19746       do j=1,nss
19747 !          print *,i,j
19748         if (newihpb(i).eq.idssb(j) .and. &
19749              newjhpb(i).eq.jdssb(j)) found=.true.
19750       enddo
19751 #ifndef CLUST
19752 #ifndef WHAM
19753 !        write(iout,*) "found",found,i,j
19754       if (.not.found.and.fg_rank.eq.0) &
19755           write(iout,'(a15,f12.2,f8.1,2i5)') &
19756            "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
19757 #endif
19758 #endif
19759       enddo
19760
19761       nss=newnss
19762       do i=1,nss
19763       idssb(i)=newihpb(i)
19764       jdssb(i)=newjhpb(i)
19765       enddo
19766
19767       return
19768       end subroutine dyn_set_nss
19769 ! Lipid transfer energy function
19770       subroutine Eliptransfer(eliptran)
19771 !C this is done by Adasko
19772 !C      print *,"wchodze"
19773 !C structure of box:
19774 !C      water
19775 !C--bordliptop-- buffore starts
19776 !C--bufliptop--- here true lipid starts
19777 !C      lipid
19778 !C--buflipbot--- lipid ends buffore starts
19779 !C--bordlipbot--buffore ends
19780       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
19781       integer :: i
19782       eliptran=0.0
19783 !      print *, "I am in eliptran"
19784       do i=ilip_start,ilip_end
19785 !C       do i=1,1
19786       if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
19787        cycle
19788
19789       positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
19790       if (positi.le.0.0) positi=positi+boxzsize
19791 !C        print *,i
19792 !C first for peptide groups
19793 !c for each residue check if it is in lipid or lipid water border area
19794        if ((positi.gt.bordlipbot)  &
19795       .and.(positi.lt.bordliptop)) then
19796 !C the energy transfer exist
19797       if (positi.lt.buflipbot) then
19798 !C what fraction I am in
19799        fracinbuf=1.0d0-      &
19800            ((positi-bordlipbot)/lipbufthick)
19801 !C lipbufthick is thickenes of lipid buffore
19802        sslip=sscalelip(fracinbuf)
19803        ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19804        eliptran=eliptran+sslip*pepliptran
19805        gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19806        gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19807 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19808
19809 !C        print *,"doing sccale for lower part"
19810 !C         print *,i,sslip,fracinbuf,ssgradlip
19811       elseif (positi.gt.bufliptop) then
19812        fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
19813        sslip=sscalelip(fracinbuf)
19814        ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19815        eliptran=eliptran+sslip*pepliptran
19816        gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19817        gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19818 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19819 !C          print *, "doing sscalefor top part"
19820 !C         print *,i,sslip,fracinbuf,ssgradlip
19821       else
19822        eliptran=eliptran+pepliptran
19823 !C         print *,"I am in true lipid"
19824       endif
19825 !C       else
19826 !C       eliptran=elpitran+0.0 ! I am in water
19827        endif
19828        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
19829        enddo
19830 ! here starts the side chain transfer
19831        do i=ilip_start,ilip_end
19832       if (itype(i,1).eq.ntyp1) cycle
19833       positi=(mod(c(3,i+nres),boxzsize))
19834       if (positi.le.0) positi=positi+boxzsize
19835 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19836 !c for each residue check if it is in lipid or lipid water border area
19837 !C       respos=mod(c(3,i+nres),boxzsize)
19838 !C       print *,positi,bordlipbot,buflipbot
19839        if ((positi.gt.bordlipbot) &
19840        .and.(positi.lt.bordliptop)) then
19841 !C the energy transfer exist
19842       if (positi.lt.buflipbot) then
19843        fracinbuf=1.0d0-   &
19844          ((positi-bordlipbot)/lipbufthick)
19845 !C lipbufthick is thickenes of lipid buffore
19846        sslip=sscalelip(fracinbuf)
19847        ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19848        eliptran=eliptran+sslip*liptranene(itype(i,1))
19849        gliptranx(3,i)=gliptranx(3,i) &
19850       +ssgradlip*liptranene(itype(i,1))
19851        gliptranc(3,i-1)= gliptranc(3,i-1) &
19852       +ssgradlip*liptranene(itype(i,1))
19853 !C         print *,"doing sccale for lower part"
19854       elseif (positi.gt.bufliptop) then
19855        fracinbuf=1.0d0-  &
19856       ((bordliptop-positi)/lipbufthick)
19857        sslip=sscalelip(fracinbuf)
19858        ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19859        eliptran=eliptran+sslip*liptranene(itype(i,1))
19860        gliptranx(3,i)=gliptranx(3,i)  &
19861        +ssgradlip*liptranene(itype(i,1))
19862        gliptranc(3,i-1)= gliptranc(3,i-1) &
19863       +ssgradlip*liptranene(itype(i,1))
19864 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19865       else
19866        eliptran=eliptran+liptranene(itype(i,1))
19867 !C         print *,"I am in true lipid"
19868       endif
19869       endif ! if in lipid or buffor
19870 !C       else
19871 !C       eliptran=elpitran+0.0 ! I am in water
19872       if (energy_dec) write(iout,*) i,"eliptran=",eliptran
19873        enddo
19874        return
19875        end  subroutine Eliptransfer
19876 !----------------------------------NANO FUNCTIONS
19877 !C-----------------------------------------------------------------------
19878 !C-----------------------------------------------------------
19879 !C This subroutine is to mimic the histone like structure but as well can be
19880 !C utilizet to nanostructures (infinit) small modification has to be used to
19881 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19882 !C gradient has to be modified at the ends
19883 !C The energy function is Kihara potential
19884 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19885 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19886 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19887 !C simple Kihara potential
19888       subroutine calctube(Etube)
19889       real(kind=8),dimension(3) :: vectube
19890       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19891        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
19892        sc_aa_tube,sc_bb_tube
19893       integer :: i,j,iti
19894       Etube=0.0d0
19895       do i=itube_start,itube_end
19896       enetube(i)=0.0d0
19897       enetube(i+nres)=0.0d0
19898       enddo
19899 !C first we calculate the distance from tube center
19900 !C for UNRES
19901        do i=itube_start,itube_end
19902 !C lets ommit dummy atoms for now
19903        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19904 !C now calculate distance from center of tube and direction vectors
19905       xmin=boxxsize
19906       ymin=boxysize
19907 ! Find minimum distance in periodic box
19908       do j=-1,1
19909        vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19910        vectube(1)=vectube(1)+boxxsize*j
19911        vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19912        vectube(2)=vectube(2)+boxysize*j
19913        xminact=abs(vectube(1)-tubecenter(1))
19914        yminact=abs(vectube(2)-tubecenter(2))
19915          if (xmin.gt.xminact) then
19916           xmin=xminact
19917           xtemp=vectube(1)
19918          endif
19919          if (ymin.gt.yminact) then
19920            ymin=yminact
19921            ytemp=vectube(2)
19922           endif
19923        enddo
19924       vectube(1)=xtemp
19925       vectube(2)=ytemp
19926       vectube(1)=vectube(1)-tubecenter(1)
19927       vectube(2)=vectube(2)-tubecenter(2)
19928
19929 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19930 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19931
19932 !C as the tube is infinity we do not calculate the Z-vector use of Z
19933 !C as chosen axis
19934       vectube(3)=0.0d0
19935 !C now calculte the distance
19936        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19937 !C now normalize vector
19938       vectube(1)=vectube(1)/tub_r
19939       vectube(2)=vectube(2)/tub_r
19940 !C calculte rdiffrence between r and r0
19941       rdiff=tub_r-tubeR0
19942 !C and its 6 power
19943       rdiff6=rdiff**6.0d0
19944 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19945        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19946 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19947 !C       print *,rdiff,rdiff6,pep_aa_tube
19948 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19949 !C now we calculate gradient
19950        fac=(-12.0d0*pep_aa_tube/rdiff6- &
19951           6.0d0*pep_bb_tube)/rdiff6/rdiff
19952 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19953 !C     &rdiff,fac
19954 !C now direction of gg_tube vector
19955       do j=1,3
19956       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19957       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19958       enddo
19959       enddo
19960 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19961 !C        print *,gg_tube(1,0),"TU"
19962
19963
19964        do i=itube_start,itube_end
19965 !C Lets not jump over memory as we use many times iti
19966        iti=itype(i,1)
19967 !C lets ommit dummy atoms for now
19968        if ((iti.eq.ntyp1)  &
19969 !C in UNRES uncomment the line below as GLY has no side-chain...
19970 !C      .or.(iti.eq.10)
19971       ) cycle
19972       xmin=boxxsize
19973       ymin=boxysize
19974       do j=-1,1
19975        vectube(1)=mod((c(1,i+nres)),boxxsize)
19976        vectube(1)=vectube(1)+boxxsize*j
19977        vectube(2)=mod((c(2,i+nres)),boxysize)
19978        vectube(2)=vectube(2)+boxysize*j
19979
19980        xminact=abs(vectube(1)-tubecenter(1))
19981        yminact=abs(vectube(2)-tubecenter(2))
19982          if (xmin.gt.xminact) then
19983           xmin=xminact
19984           xtemp=vectube(1)
19985          endif
19986          if (ymin.gt.yminact) then
19987            ymin=yminact
19988            ytemp=vectube(2)
19989           endif
19990        enddo
19991       vectube(1)=xtemp
19992       vectube(2)=ytemp
19993 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19994 !C     &     tubecenter(2)
19995       vectube(1)=vectube(1)-tubecenter(1)
19996       vectube(2)=vectube(2)-tubecenter(2)
19997
19998 !C as the tube is infinity we do not calculate the Z-vector use of Z
19999 !C as chosen axis
20000       vectube(3)=0.0d0
20001 !C now calculte the distance
20002        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20003 !C now normalize vector
20004       vectube(1)=vectube(1)/tub_r
20005       vectube(2)=vectube(2)/tub_r
20006
20007 !C calculte rdiffrence between r and r0
20008       rdiff=tub_r-tubeR0
20009 !C and its 6 power
20010       rdiff6=rdiff**6.0d0
20011 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20012        sc_aa_tube=sc_aa_tube_par(iti)
20013        sc_bb_tube=sc_bb_tube_par(iti)
20014        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20015        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
20016            6.0d0*sc_bb_tube/rdiff6/rdiff
20017 !C now direction of gg_tube vector
20018        do j=1,3
20019         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
20020         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
20021        enddo
20022       enddo
20023       do i=itube_start,itube_end
20024         Etube=Etube+enetube(i)+enetube(i+nres)
20025       enddo
20026 !C        print *,"ETUBE", etube
20027       return
20028       end subroutine calctube
20029 !C TO DO 1) add to total energy
20030 !C       2) add to gradient summation
20031 !C       3) add reading parameters (AND of course oppening of PARAM file)
20032 !C       4) add reading the center of tube
20033 !C       5) add COMMONs
20034 !C       6) add to zerograd
20035 !C       7) allocate matrices
20036
20037
20038 !C-----------------------------------------------------------------------
20039 !C-----------------------------------------------------------
20040 !C This subroutine is to mimic the histone like structure but as well can be
20041 !C utilizet to nanostructures (infinit) small modification has to be used to
20042 !C make it finite (z gradient at the ends has to be changes as well as the x,y
20043 !C gradient has to be modified at the ends
20044 !C The energy function is Kihara potential
20045 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
20046 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
20047 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
20048 !C simple Kihara potential
20049       subroutine calctube2(Etube)
20050           real(kind=8),dimension(3) :: vectube
20051       real(kind=8) :: Etube,xtemp,xminact,yminact,&
20052        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
20053        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
20054       integer:: i,j,iti
20055       Etube=0.0d0
20056       do i=itube_start,itube_end
20057       enetube(i)=0.0d0
20058       enetube(i+nres)=0.0d0
20059       enddo
20060 !C first we calculate the distance from tube center
20061 !C first sugare-phosphate group for NARES this would be peptide group
20062 !C for UNRES
20063        do i=itube_start,itube_end
20064 !C lets ommit dummy atoms for now
20065
20066        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
20067 !C now calculate distance from center of tube and direction vectors
20068 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
20069 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
20070 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
20071 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
20072       xmin=boxxsize
20073       ymin=boxysize
20074       do j=-1,1
20075        vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
20076        vectube(1)=vectube(1)+boxxsize*j
20077        vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
20078        vectube(2)=vectube(2)+boxysize*j
20079
20080        xminact=abs(vectube(1)-tubecenter(1))
20081        yminact=abs(vectube(2)-tubecenter(2))
20082          if (xmin.gt.xminact) then
20083           xmin=xminact
20084           xtemp=vectube(1)
20085          endif
20086          if (ymin.gt.yminact) then
20087            ymin=yminact
20088            ytemp=vectube(2)
20089           endif
20090        enddo
20091       vectube(1)=xtemp
20092       vectube(2)=ytemp
20093       vectube(1)=vectube(1)-tubecenter(1)
20094       vectube(2)=vectube(2)-tubecenter(2)
20095
20096 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
20097 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
20098
20099 !C as the tube is infinity we do not calculate the Z-vector use of Z
20100 !C as chosen axis
20101       vectube(3)=0.0d0
20102 !C now calculte the distance
20103        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20104 !C now normalize vector
20105       vectube(1)=vectube(1)/tub_r
20106       vectube(2)=vectube(2)/tub_r
20107 !C calculte rdiffrence between r and r0
20108       rdiff=tub_r-tubeR0
20109 !C and its 6 power
20110       rdiff6=rdiff**6.0d0
20111 !C THIS FRAGMENT MAKES TUBE FINITE
20112       positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
20113       if (positi.le.0) positi=positi+boxzsize
20114 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
20115 !c for each residue check if it is in lipid or lipid water border area
20116 !C       respos=mod(c(3,i+nres),boxzsize)
20117 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
20118        if ((positi.gt.bordtubebot)  &
20119       .and.(positi.lt.bordtubetop)) then
20120 !C the energy transfer exist
20121       if (positi.lt.buftubebot) then
20122        fracinbuf=1.0d0-  &
20123          ((positi-bordtubebot)/tubebufthick)
20124 !C lipbufthick is thickenes of lipid buffore
20125        sstube=sscalelip(fracinbuf)
20126        ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
20127 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
20128        enetube(i)=enetube(i)+sstube*tubetranenepep
20129 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
20130 !C     &+ssgradtube*tubetranene(itype(i,1))
20131 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
20132 !C     &+ssgradtube*tubetranene(itype(i,1))
20133 !C         print *,"doing sccale for lower part"
20134       elseif (positi.gt.buftubetop) then
20135        fracinbuf=1.0d0-  &
20136       ((bordtubetop-positi)/tubebufthick)
20137        sstube=sscalelip(fracinbuf)
20138        ssgradtube=sscagradlip(fracinbuf)/tubebufthick
20139        enetube(i)=enetube(i)+sstube*tubetranenepep
20140 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
20141 !C     &+ssgradtube*tubetranene(itype(i,1))
20142 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
20143 !C     &+ssgradtube*tubetranene(itype(i,1))
20144 !C          print *, "doing sscalefor top part",sslip,fracinbuf
20145       else
20146        sstube=1.0d0
20147        ssgradtube=0.0d0
20148        enetube(i)=enetube(i)+sstube*tubetranenepep
20149 !C         print *,"I am in true lipid"
20150       endif
20151       else
20152 !C          sstube=0.0d0
20153 !C          ssgradtube=0.0d0
20154       cycle
20155       endif ! if in lipid or buffor
20156
20157 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20158        enetube(i)=enetube(i)+sstube* &
20159       (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
20160 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
20161 !C       print *,rdiff,rdiff6,pep_aa_tube
20162 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20163 !C now we calculate gradient
20164        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
20165            6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
20166 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
20167 !C     &rdiff,fac
20168
20169 !C now direction of gg_tube vector
20170        do j=1,3
20171       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
20172       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
20173       enddo
20174        gg_tube(3,i)=gg_tube(3,i)  &
20175        +ssgradtube*enetube(i)/sstube/2.0d0
20176        gg_tube(3,i-1)= gg_tube(3,i-1)  &
20177        +ssgradtube*enetube(i)/sstube/2.0d0
20178
20179       enddo
20180 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
20181 !C        print *,gg_tube(1,0),"TU"
20182       do i=itube_start,itube_end
20183 !C Lets not jump over memory as we use many times iti
20184        iti=itype(i,1)
20185 !C lets ommit dummy atoms for now
20186        if ((iti.eq.ntyp1) &
20187 !!C in UNRES uncomment the line below as GLY has no side-chain...
20188          .or.(iti.eq.10) &
20189         ) cycle
20190         vectube(1)=c(1,i+nres)
20191         vectube(1)=mod(vectube(1),boxxsize)
20192         if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
20193         vectube(2)=c(2,i+nres)
20194         vectube(2)=mod(vectube(2),boxysize)
20195         if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
20196
20197       vectube(1)=vectube(1)-tubecenter(1)
20198       vectube(2)=vectube(2)-tubecenter(2)
20199 !C THIS FRAGMENT MAKES TUBE FINITE
20200       positi=(mod(c(3,i+nres),boxzsize))
20201       if (positi.le.0) positi=positi+boxzsize
20202 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
20203 !c for each residue check if it is in lipid or lipid water border area
20204 !C       respos=mod(c(3,i+nres),boxzsize)
20205 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
20206
20207        if ((positi.gt.bordtubebot)  &
20208       .and.(positi.lt.bordtubetop)) then
20209 !C the energy transfer exist
20210       if (positi.lt.buftubebot) then
20211        fracinbuf=1.0d0- &
20212           ((positi-bordtubebot)/tubebufthick)
20213 !C lipbufthick is thickenes of lipid buffore
20214        sstube=sscalelip(fracinbuf)
20215        ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
20216 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
20217        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
20218 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
20219 !C     &+ssgradtube*tubetranene(itype(i,1))
20220 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
20221 !C     &+ssgradtube*tubetranene(itype(i,1))
20222 !C         print *,"doing sccale for lower part"
20223       elseif (positi.gt.buftubetop) then
20224        fracinbuf=1.0d0- &
20225       ((bordtubetop-positi)/tubebufthick)
20226
20227        sstube=sscalelip(fracinbuf)
20228        ssgradtube=sscagradlip(fracinbuf)/tubebufthick
20229        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
20230 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
20231 !C     &+ssgradtube*tubetranene(itype(i,1))
20232 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
20233 !C     &+ssgradtube*tubetranene(itype(i,1))
20234 !C          print *, "doing sscalefor top part",sslip,fracinbuf
20235       else
20236        sstube=1.0d0
20237        ssgradtube=0.0d0
20238        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
20239 !C         print *,"I am in true lipid"
20240       endif
20241       else
20242 !C          sstube=0.0d0
20243 !C          ssgradtube=0.0d0
20244       cycle
20245       endif ! if in lipid or buffor
20246 !CEND OF FINITE FRAGMENT
20247 !C as the tube is infinity we do not calculate the Z-vector use of Z
20248 !C as chosen axis
20249       vectube(3)=0.0d0
20250 !C now calculte the distance
20251        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20252 !C now normalize vector
20253       vectube(1)=vectube(1)/tub_r
20254       vectube(2)=vectube(2)/tub_r
20255 !C calculte rdiffrence between r and r0
20256       rdiff=tub_r-tubeR0
20257 !C and its 6 power
20258       rdiff6=rdiff**6.0d0
20259 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20260        sc_aa_tube=sc_aa_tube_par(iti)
20261        sc_bb_tube=sc_bb_tube_par(iti)
20262        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
20263                    *sstube+enetube(i+nres)
20264 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20265 !C now we calculate gradient
20266        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
20267           6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
20268 !C now direction of gg_tube vector
20269        do j=1,3
20270         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
20271         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
20272        enddo
20273        gg_tube_SC(3,i)=gg_tube_SC(3,i) &
20274        +ssgradtube*enetube(i+nres)/sstube
20275        gg_tube(3,i-1)= gg_tube(3,i-1) &
20276        +ssgradtube*enetube(i+nres)/sstube
20277
20278       enddo
20279       do i=itube_start,itube_end
20280         Etube=Etube+enetube(i)+enetube(i+nres)
20281       enddo
20282 !C        print *,"ETUBE", etube
20283       return
20284       end subroutine calctube2
20285 !=====================================================================================================================================
20286       subroutine calcnano(Etube)
20287       real(kind=8),dimension(3) :: vectube
20288
20289       real(kind=8) :: Etube,xtemp,xminact,yminact,&
20290        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
20291        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
20292        integer:: i,j,iti,r
20293
20294       Etube=0.0d0
20295 !      print *,itube_start,itube_end,"poczatek"
20296       do i=itube_start,itube_end
20297       enetube(i)=0.0d0
20298       enetube(i+nres)=0.0d0
20299       enddo
20300 !C first we calculate the distance from tube center
20301 !C first sugare-phosphate group for NARES this would be peptide group
20302 !C for UNRES
20303        do i=itube_start,itube_end
20304 !C lets ommit dummy atoms for now
20305        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
20306 !C now calculate distance from center of tube and direction vectors
20307       xmin=boxxsize
20308       ymin=boxysize
20309       zmin=boxzsize
20310
20311       do j=-1,1
20312        vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
20313        vectube(1)=vectube(1)+boxxsize*j
20314        vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
20315        vectube(2)=vectube(2)+boxysize*j
20316        vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
20317        vectube(3)=vectube(3)+boxzsize*j
20318
20319
20320        xminact=dabs(vectube(1)-tubecenter(1))
20321        yminact=dabs(vectube(2)-tubecenter(2))
20322        zminact=dabs(vectube(3)-tubecenter(3))
20323
20324          if (xmin.gt.xminact) then
20325           xmin=xminact
20326           xtemp=vectube(1)
20327          endif
20328          if (ymin.gt.yminact) then
20329            ymin=yminact
20330            ytemp=vectube(2)
20331           endif
20332          if (zmin.gt.zminact) then
20333            zmin=zminact
20334            ztemp=vectube(3)
20335           endif
20336        enddo
20337       vectube(1)=xtemp
20338       vectube(2)=ytemp
20339       vectube(3)=ztemp
20340
20341       vectube(1)=vectube(1)-tubecenter(1)
20342       vectube(2)=vectube(2)-tubecenter(2)
20343       vectube(3)=vectube(3)-tubecenter(3)
20344
20345 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
20346 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
20347 !C as the tube is infinity we do not calculate the Z-vector use of Z
20348 !C as chosen axis
20349 !C      vectube(3)=0.0d0
20350 !C now calculte the distance
20351        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20352 !C now normalize vector
20353       vectube(1)=vectube(1)/tub_r
20354       vectube(2)=vectube(2)/tub_r
20355       vectube(3)=vectube(3)/tub_r
20356 !C calculte rdiffrence between r and r0
20357       rdiff=tub_r-tubeR0
20358 !C and its 6 power
20359       rdiff6=rdiff**6.0d0
20360 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20361        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
20362 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
20363 !C       print *,rdiff,rdiff6,pep_aa_tube
20364 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20365 !C now we calculate gradient
20366        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
20367           6.0d0*pep_bb_tube)/rdiff6/rdiff
20368 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
20369 !C     &rdiff,fac
20370        if (acavtubpep.eq.0.0d0) then
20371 !C go to 667
20372        enecavtube(i)=0.0
20373        faccav=0.0
20374        else
20375        denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
20376        enecavtube(i)=  &
20377       (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
20378       /denominator
20379        enecavtube(i)=0.0
20380        faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
20381       *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
20382       +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
20383       /denominator**2.0d0
20384 !C         faccav=0.0
20385 !C         fac=fac+faccav
20386 !C 667     continue
20387        endif
20388         if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
20389       do j=1,3
20390       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
20391       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
20392       enddo
20393       enddo
20394
20395        do i=itube_start,itube_end
20396       enecavtube(i)=0.0d0
20397 !C Lets not jump over memory as we use many times iti
20398        iti=itype(i,1)
20399 !C lets ommit dummy atoms for now
20400        if ((iti.eq.ntyp1) &
20401 !C in UNRES uncomment the line below as GLY has no side-chain...
20402 !C      .or.(iti.eq.10)
20403        ) cycle
20404       xmin=boxxsize
20405       ymin=boxysize
20406       zmin=boxzsize
20407       do j=-1,1
20408        vectube(1)=dmod((c(1,i+nres)),boxxsize)
20409        vectube(1)=vectube(1)+boxxsize*j
20410        vectube(2)=dmod((c(2,i+nres)),boxysize)
20411        vectube(2)=vectube(2)+boxysize*j
20412        vectube(3)=dmod((c(3,i+nres)),boxzsize)
20413        vectube(3)=vectube(3)+boxzsize*j
20414
20415
20416        xminact=dabs(vectube(1)-tubecenter(1))
20417        yminact=dabs(vectube(2)-tubecenter(2))
20418        zminact=dabs(vectube(3)-tubecenter(3))
20419
20420          if (xmin.gt.xminact) then
20421           xmin=xminact
20422           xtemp=vectube(1)
20423          endif
20424          if (ymin.gt.yminact) then
20425            ymin=yminact
20426            ytemp=vectube(2)
20427           endif
20428          if (zmin.gt.zminact) then
20429            zmin=zminact
20430            ztemp=vectube(3)
20431           endif
20432        enddo
20433       vectube(1)=xtemp
20434       vectube(2)=ytemp
20435       vectube(3)=ztemp
20436
20437 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
20438 !C     &     tubecenter(2)
20439       vectube(1)=vectube(1)-tubecenter(1)
20440       vectube(2)=vectube(2)-tubecenter(2)
20441       vectube(3)=vectube(3)-tubecenter(3)
20442 !C now calculte the distance
20443        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20444 !C now normalize vector
20445       vectube(1)=vectube(1)/tub_r
20446       vectube(2)=vectube(2)/tub_r
20447       vectube(3)=vectube(3)/tub_r
20448
20449 !C calculte rdiffrence between r and r0
20450       rdiff=tub_r-tubeR0
20451 !C and its 6 power
20452       rdiff6=rdiff**6.0d0
20453        sc_aa_tube=sc_aa_tube_par(iti)
20454        sc_bb_tube=sc_bb_tube_par(iti)
20455        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20456 !C       enetube(i+nres)=0.0d0
20457 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20458 !C now we calculate gradient
20459        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
20460           6.0d0*sc_bb_tube/rdiff6/rdiff
20461 !C       fac=0.0
20462 !C now direction of gg_tube vector
20463 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
20464        if (acavtub(iti).eq.0.0d0) then
20465 !C go to 667
20466        enecavtube(i+nres)=0.0d0
20467        faccav=0.0d0
20468        else
20469        denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
20470        enecavtube(i+nres)=   &
20471       (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
20472       /denominator
20473 !C         enecavtube(i)=0.0
20474        faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
20475       *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
20476       +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
20477       /denominator**2.0d0
20478 !C         faccav=0.0
20479        fac=fac+faccav
20480 !C 667     continue
20481        endif
20482 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
20483 !C     &   enecavtube(i),faccav
20484 !C         print *,"licz=",
20485 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
20486 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
20487        do j=1,3
20488         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
20489         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
20490        enddo
20491         if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
20492       enddo
20493
20494
20495
20496       do i=itube_start,itube_end
20497         Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
20498        +enecavtube(i+nres)
20499       enddo
20500 !        do i=1,20
20501 !         print *,"begin", i,"a"
20502 !         do r=1,10000
20503 !          rdiff=r/100.0d0
20504 !          rdiff6=rdiff**6.0d0
20505 !          sc_aa_tube=sc_aa_tube_par(i)
20506 !          sc_bb_tube=sc_bb_tube_par(i)
20507 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20508 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
20509 !          enecavtube(i)=   &
20510 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
20511 !         /denominator
20512
20513 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
20514 !         enddo
20515 !         print *,"end",i,"a"
20516 !        enddo
20517 !C        print *,"ETUBE", etube
20518       return
20519       end subroutine calcnano
20520
20521 !===============================================
20522 !--------------------------------------------------------------------------------
20523 !C first for shielding is setting of function of side-chains
20524
20525        subroutine set_shield_fac2
20526        real(kind=8) :: div77_81=0.974996043d0, &
20527       div4_81=0.2222222222d0
20528        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
20529        scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
20530        short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
20531        sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
20532 !C the vector between center of side_chain and peptide group
20533        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
20534        pept_group,costhet_grad,cosphi_grad_long, &
20535        cosphi_grad_loc,pep_side_norm,side_calf_norm, &
20536        sh_frac_dist_grad,pep_side
20537       integer i,j,k
20538 !C      write(2,*) "ivec",ivec_start,ivec_end
20539       do i=1,nres
20540       fac_shield(i)=0.0d0
20541       ishield_list(i)=0
20542       do j=1,3
20543       grad_shield(j,i)=0.0d0
20544       enddo
20545       enddo
20546       do i=ivec_start,ivec_end
20547 !C      do i=1,nres-1
20548 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
20549 !      ishield_list(i)=0
20550       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
20551 !Cif there two consequtive dummy atoms there is no peptide group between them
20552 !C the line below has to be changed for FGPROC>1
20553       VolumeTotal=0.0
20554       do k=1,nres
20555        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
20556        dist_pep_side=0.0
20557        dist_side_calf=0.0
20558        do j=1,3
20559 !C first lets set vector conecting the ithe side-chain with kth side-chain
20560       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
20561 !C      pep_side(j)=2.0d0
20562 !C and vector conecting the side-chain with its proper calfa
20563       side_calf(j)=c(j,k+nres)-c(j,k)
20564 !C      side_calf(j)=2.0d0
20565       pept_group(j)=c(j,i)-c(j,i+1)
20566 !C lets have their lenght
20567       dist_pep_side=pep_side(j)**2+dist_pep_side
20568       dist_side_calf=dist_side_calf+side_calf(j)**2
20569       dist_pept_group=dist_pept_group+pept_group(j)**2
20570       enddo
20571        dist_pep_side=sqrt(dist_pep_side)
20572        dist_pept_group=sqrt(dist_pept_group)
20573        dist_side_calf=sqrt(dist_side_calf)
20574       do j=1,3
20575       pep_side_norm(j)=pep_side(j)/dist_pep_side
20576       side_calf_norm(j)=dist_side_calf
20577       enddo
20578 !C now sscale fraction
20579        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
20580 !       print *,buff_shield,"buff",sh_frac_dist
20581 !C now sscale
20582       if (sh_frac_dist.le.0.0) cycle
20583 !C        print *,ishield_list(i),i
20584 !C If we reach here it means that this side chain reaches the shielding sphere
20585 !C Lets add him to the list for gradient
20586       ishield_list(i)=ishield_list(i)+1
20587 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
20588 !C this list is essential otherwise problem would be O3
20589       shield_list(ishield_list(i),i)=k
20590 !C Lets have the sscale value
20591       if (sh_frac_dist.gt.1.0) then
20592        scale_fac_dist=1.0d0
20593        do j=1,3
20594        sh_frac_dist_grad(j)=0.0d0
20595        enddo
20596       else
20597        scale_fac_dist=-sh_frac_dist*sh_frac_dist &
20598                   *(2.0d0*sh_frac_dist-3.0d0)
20599        fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
20600                    /dist_pep_side/buff_shield*0.5d0
20601        do j=1,3
20602        sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
20603 !C         sh_frac_dist_grad(j)=0.0d0
20604 !C         scale_fac_dist=1.0d0
20605 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
20606 !C     &                    sh_frac_dist_grad(j)
20607        enddo
20608       endif
20609 !C this is what is now we have the distance scaling now volume...
20610       short=short_r_sidechain(itype(k,1))
20611       long=long_r_sidechain(itype(k,1))
20612       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
20613       sinthet=short/dist_pep_side*costhet
20614 !      print *,"SORT",short,long,sinthet,costhet
20615 !C now costhet_grad
20616 !C       costhet=0.6d0
20617 !C       sinthet=0.8
20618        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
20619 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
20620 !C     &             -short/dist_pep_side**2/costhet)
20621 !C       costhet_fac=0.0d0
20622        do j=1,3
20623        costhet_grad(j)=costhet_fac*pep_side(j)
20624        enddo
20625 !C remember for the final gradient multiply costhet_grad(j)
20626 !C for side_chain by factor -2 !
20627 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
20628 !C pep_side0pept_group is vector multiplication
20629       pep_side0pept_group=0.0d0
20630       do j=1,3
20631       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
20632       enddo
20633       cosalfa=(pep_side0pept_group/ &
20634       (dist_pep_side*dist_side_calf))
20635       fac_alfa_sin=1.0d0-cosalfa**2
20636       fac_alfa_sin=dsqrt(fac_alfa_sin)
20637       rkprim=fac_alfa_sin*(long-short)+short
20638 !C      rkprim=short
20639
20640 !C now costhet_grad
20641        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
20642 !C       cosphi=0.6
20643        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
20644        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
20645          dist_pep_side**2)
20646 !C       sinphi=0.8
20647        do j=1,3
20648        cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
20649       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
20650       *(long-short)/fac_alfa_sin*cosalfa/ &
20651       ((dist_pep_side*dist_side_calf))* &
20652       ((side_calf(j))-cosalfa* &
20653       ((pep_side(j)/dist_pep_side)*dist_side_calf))
20654 !C       cosphi_grad_long(j)=0.0d0
20655       cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
20656       *(long-short)/fac_alfa_sin*cosalfa &
20657       /((dist_pep_side*dist_side_calf))* &
20658       (pep_side(j)- &
20659       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
20660 !C       cosphi_grad_loc(j)=0.0d0
20661        enddo
20662 !C      print *,sinphi,sinthet
20663       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
20664                    /VSolvSphere_div
20665 !C     &                    *wshield
20666 !C now the gradient...
20667       do j=1,3
20668       grad_shield(j,i)=grad_shield(j,i) &
20669 !C gradient po skalowaniu
20670                  +(sh_frac_dist_grad(j)*VofOverlap &
20671 !C  gradient po costhet
20672           +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
20673       (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
20674           sinphi/sinthet*costhet*costhet_grad(j) &
20675          +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20676       )*wshield
20677 !C grad_shield_side is Cbeta sidechain gradient
20678       grad_shield_side(j,ishield_list(i),i)=&
20679            (sh_frac_dist_grad(j)*-2.0d0&
20680            *VofOverlap&
20681           -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20682        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
20683           sinphi/sinthet*costhet*costhet_grad(j)&
20684          +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20685           )*wshield
20686 !       print *, 1.0d0/(-dsqrt(1.0d0-sinphi*sinthet)),&
20687 !            sinphi/sinthet,&
20688 !           +sinthet/sinphi,"HERE"
20689        grad_shield_loc(j,ishield_list(i),i)=   &
20690           scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20691       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
20692           sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
20693            ))&
20694            *wshield
20695 !         print *,grad_shield_loc(j,ishield_list(i),i)
20696       enddo
20697       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
20698       enddo
20699       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
20700
20701 !      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
20702       enddo
20703       return
20704       end subroutine set_shield_fac2
20705 !----------------------------------------------------------------------------
20706 ! SOUBROUTINE FOR AFM
20707        subroutine AFMvel(Eafmforce)
20708        use MD_data, only:totTafm
20709       real(kind=8),dimension(3) :: diffafm
20710       real(kind=8) :: afmdist,Eafmforce
20711        integer :: i
20712 !C Only for check grad COMMENT if not used for checkgrad
20713 !C      totT=3.0d0
20714 !C--------------------------------------------------------
20715 !C      print *,"wchodze"
20716       afmdist=0.0d0
20717       Eafmforce=0.0d0
20718       do i=1,3
20719       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20720       afmdist=afmdist+diffafm(i)**2
20721       enddo
20722       afmdist=dsqrt(afmdist)
20723 !      totTafm=3.0
20724       Eafmforce=0.5d0*forceAFMconst &
20725       *(distafminit+totTafm*velAFMconst-afmdist)**2
20726 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
20727       do i=1,3
20728       gradafm(i,afmend-1)=-forceAFMconst* &
20729        (distafminit+totTafm*velAFMconst-afmdist) &
20730        *diffafm(i)/afmdist
20731       gradafm(i,afmbeg-1)=forceAFMconst* &
20732       (distafminit+totTafm*velAFMconst-afmdist) &
20733       *diffafm(i)/afmdist
20734       enddo
20735 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
20736       return
20737       end subroutine AFMvel
20738 !---------------------------------------------------------
20739        subroutine AFMforce(Eafmforce)
20740
20741       real(kind=8),dimension(3) :: diffafm
20742 !      real(kind=8) ::afmdist
20743       real(kind=8) :: afmdist,Eafmforce
20744       integer :: i
20745       afmdist=0.0d0
20746       Eafmforce=0.0d0
20747       do i=1,3
20748       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20749       afmdist=afmdist+diffafm(i)**2
20750       enddo
20751       afmdist=dsqrt(afmdist)
20752 !      print *,afmdist,distafminit
20753       Eafmforce=-forceAFMconst*(afmdist-distafminit)
20754       do i=1,3
20755       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
20756       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
20757       enddo
20758 !C      print *,'AFM',Eafmforce
20759       return
20760       end subroutine AFMforce
20761
20762 !-----------------------------------------------------------------------------
20763 #ifdef WHAM
20764       subroutine read_ssHist
20765 !      implicit none
20766 !      Includes
20767 !      include 'DIMENSIONS'
20768 !      include "DIMENSIONS.FREE"
20769 !      include 'COMMON.FREE'
20770 !     Local variables
20771       integer :: i,j
20772       character(len=80) :: controlcard
20773
20774       do i=1,dyn_nssHist
20775       call card_concat(controlcard,.true.)
20776       read(controlcard,*) &
20777            dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
20778       enddo
20779
20780       return
20781       end subroutine read_ssHist
20782 #endif
20783 !-----------------------------------------------------------------------------
20784       integer function indmat(i,j)
20785 !el
20786 ! get the position of the jth ijth fragment of the chain coordinate system
20787 ! in the fromto array.
20788       integer :: i,j
20789
20790       indmat=((2*(nres-2)-i)*(i-1))/2+j-1
20791       return
20792       end function indmat
20793 !-----------------------------------------------------------------------------
20794       real(kind=8) function sigm(x)
20795 !el
20796        real(kind=8) :: x
20797       sigm=0.25d0*x
20798       return
20799       end function sigm
20800 !-----------------------------------------------------------------------------
20801 !-----------------------------------------------------------------------------
20802       subroutine alloc_ener_arrays
20803 !EL Allocation of arrays used by module energy
20804       use MD_data, only: mset
20805 !el local variables
20806       integer :: i,j
20807
20808       if(nres.lt.100) then
20809       maxconts=10*nres
20810       elseif(nres.lt.200) then
20811       maxconts=10*nres      ! Max. number of contacts per residue
20812       else
20813       maxconts=10*nres ! (maxconts=maxres/4)
20814       endif
20815       maxcont=100*nres      ! Max. number of SC contacts
20816       maxvar=6*nres      ! Max. number of variables
20817 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20818       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20819 !----------------------
20820 ! arrays in subroutine init_int_table
20821 !el#ifdef MPI
20822 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
20823 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
20824 !el#endif
20825       allocate(nint_gr(nres))
20826       allocate(nscp_gr(nres))
20827       allocate(ielstart(nres))
20828       allocate(ielend(nres))
20829 !(maxres)
20830       allocate(istart(nres,maxint_gr))
20831       allocate(iend(nres,maxint_gr))
20832 !(maxres,maxint_gr)
20833       allocate(iscpstart(nres,maxint_gr))
20834       allocate(iscpend(nres,maxint_gr))
20835 !(maxres,maxint_gr)
20836       allocate(ielstart_vdw(nres))
20837       allocate(ielend_vdw(nres))
20838 !(maxres)
20839       allocate(nint_gr_nucl(nres))
20840       allocate(nscp_gr_nucl(nres))
20841       allocate(ielstart_nucl(nres))
20842       allocate(ielend_nucl(nres))
20843 !(maxres)
20844       allocate(istart_nucl(nres,maxint_gr))
20845       allocate(iend_nucl(nres,maxint_gr))
20846 !(maxres,maxint_gr)
20847       allocate(iscpstart_nucl(nres,maxint_gr))
20848       allocate(iscpend_nucl(nres,maxint_gr))
20849 !(maxres,maxint_gr)
20850       allocate(ielstart_vdw_nucl(nres))
20851       allocate(ielend_vdw_nucl(nres))
20852
20853       allocate(lentyp(0:nfgtasks-1))
20854 !(0:maxprocs-1)
20855 !----------------------
20856 ! commom.contacts
20857 !      common /contacts/
20858       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
20859       allocate(icont(2,maxcont))
20860 !(2,maxcont)
20861 !      common /contacts1/
20862       allocate(num_cont(0:nres+4))
20863 !(maxres)
20864       allocate(jcont(maxconts,nres))
20865 !(maxconts,maxres)
20866       allocate(facont(maxconts,nres))
20867 !(maxconts,maxres)
20868       allocate(gacont(3,maxconts,nres))
20869 !(3,maxconts,maxres)
20870 !      common /contacts_hb/
20871       allocate(gacontp_hb1(3,maxconts,nres))
20872       allocate(gacontp_hb2(3,maxconts,nres))
20873       allocate(gacontp_hb3(3,maxconts,nres))
20874       allocate(gacontm_hb1(3,maxconts,nres))
20875       allocate(gacontm_hb2(3,maxconts,nres))
20876       allocate(gacontm_hb3(3,maxconts,nres))
20877       allocate(gacont_hbr(3,maxconts,nres))
20878       allocate(grij_hb_cont(3,maxconts,nres))
20879         !(3,maxconts,maxres)
20880       allocate(facont_hb(maxconts,nres))
20881
20882       allocate(ees0p(maxconts,nres))
20883       allocate(ees0m(maxconts,nres))
20884       allocate(d_cont(maxconts,nres))
20885       allocate(ees0plist(maxconts,nres))
20886
20887 !(maxconts,maxres)
20888       allocate(num_cont_hb(nres))
20889 !(maxres)
20890       allocate(jcont_hb(maxconts,nres))
20891 !(maxconts,maxres)
20892 !      common /rotat/
20893       allocate(Ug(2,2,nres))
20894       allocate(Ugder(2,2,nres))
20895       allocate(Ug2(2,2,nres))
20896       allocate(Ug2der(2,2,nres))
20897 !(2,2,maxres)
20898       allocate(obrot(2,nres))
20899       allocate(obrot2(2,nres))
20900       allocate(obrot_der(2,nres))
20901       allocate(obrot2_der(2,nres))
20902 !(2,maxres)
20903 !      common /precomp1/
20904       allocate(mu(2,nres))
20905       allocate(muder(2,nres))
20906       allocate(Ub2(2,nres))
20907       Ub2(1,:)=0.0d0
20908       Ub2(2,:)=0.0d0
20909       allocate(Ub2der(2,nres))
20910       allocate(Ctobr(2,nres))
20911       allocate(Ctobrder(2,nres))
20912       allocate(Dtobr2(2,nres))
20913       allocate(Dtobr2der(2,nres))
20914 !(2,maxres)
20915       allocate(EUg(2,2,nres))
20916       allocate(EUgder(2,2,nres))
20917       allocate(CUg(2,2,nres))
20918       allocate(CUgder(2,2,nres))
20919       allocate(DUg(2,2,nres))
20920       allocate(Dugder(2,2,nres))
20921       allocate(DtUg2(2,2,nres))
20922       allocate(DtUg2der(2,2,nres))
20923 !(2,2,maxres)
20924 !      common /precomp2/
20925       allocate(Ug2Db1t(2,nres))
20926       allocate(Ug2Db1tder(2,nres))
20927       allocate(CUgb2(2,nres))
20928       allocate(CUgb2der(2,nres))
20929 !(2,maxres)
20930       allocate(EUgC(2,2,nres))
20931       allocate(EUgCder(2,2,nres))
20932       allocate(EUgD(2,2,nres))
20933       allocate(EUgDder(2,2,nres))
20934       allocate(DtUg2EUg(2,2,nres))
20935       allocate(Ug2DtEUg(2,2,nres))
20936 !(2,2,maxres)
20937       allocate(Ug2DtEUgder(2,2,2,nres))
20938       allocate(DtUg2EUgder(2,2,2,nres))
20939 !(2,2,2,maxres)
20940       allocate(b1(2,nres))      !(2,-maxtor:maxtor)
20941       allocate(b2(2,nres))      !(2,-maxtor:maxtor)
20942       allocate(b1tilde(2,nres)) !(2,-maxtor:maxtor)
20943       allocate(b2tilde(2,nres)) !(2,-maxtor:maxtor)
20944
20945       allocate(ctilde(2,2,nres))
20946       allocate(dtilde(2,2,nres)) !(2,2,-maxtor:maxtor)
20947       allocate(gtb1(2,nres))
20948       allocate(gtb2(2,nres))
20949       allocate(cc(2,2,nres))
20950       allocate(dd(2,2,nres))
20951       allocate(ee(2,2,nres))
20952       allocate(gtcc(2,2,nres))
20953       allocate(gtdd(2,2,nres))
20954       allocate(gtee(2,2,nres))
20955       allocate(gUb2(2,nres))
20956       allocate(gteUg(2,2,nres))
20957
20958 !      common /rotat_old/
20959       allocate(costab(nres))
20960       allocate(sintab(nres))
20961       allocate(costab2(nres))
20962       allocate(sintab2(nres))
20963 !(maxres)
20964 !      common /dipmat/
20965       allocate(a_chuj(2,2,maxconts,nres))
20966 !(2,2,maxconts,maxres)(maxconts=maxres/4)
20967       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
20968 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
20969 !      common /contdistrib/
20970       allocate(ncont_sent(nres))
20971       allocate(ncont_recv(nres))
20972
20973       allocate(iat_sent(nres))
20974 !(maxres)
20975       allocate(iint_sent(4,nres,nres))
20976       allocate(iint_sent_local(4,nres,nres))
20977 !(4,maxres,maxres)
20978       allocate(iturn3_sent(4,0:nres+4))
20979       allocate(iturn4_sent(4,0:nres+4))
20980       allocate(iturn3_sent_local(4,nres))
20981       allocate(iturn4_sent_local(4,nres))
20982 !(4,maxres)
20983       allocate(itask_cont_from(0:nfgtasks-1))
20984       allocate(itask_cont_to(0:nfgtasks-1))
20985 !(0:max_fg_procs-1)
20986
20987
20988
20989 !----------------------
20990 ! commom.deriv;
20991 !      common /derivat/
20992       allocate(dcdv(6,maxdim))
20993       allocate(dxdv(6,maxdim))
20994 !(6,maxdim)
20995       allocate(dxds(6,nres))
20996 !(6,maxres)
20997       allocate(gradx(3,-1:nres,0:2))
20998       allocate(gradc(3,-1:nres,0:2))
20999 !(3,maxres,2)
21000       allocate(gvdwx(3,-1:nres))
21001       allocate(gvdwc(3,-1:nres))
21002       allocate(gelc(3,-1:nres))
21003       allocate(gelc_long(3,-1:nres))
21004       allocate(gvdwpp(3,-1:nres))
21005       allocate(gvdwc_scpp(3,-1:nres))
21006       allocate(gradx_scp(3,-1:nres))
21007       allocate(gvdwc_scp(3,-1:nres))
21008       allocate(ghpbx(3,-1:nres))
21009       allocate(ghpbc(3,-1:nres))
21010       allocate(gradcorr(3,-1:nres))
21011       allocate(gradcorr_long(3,-1:nres))
21012       allocate(gradcorr5_long(3,-1:nres))
21013       allocate(gradcorr6_long(3,-1:nres))
21014       allocate(gcorr6_turn_long(3,-1:nres))
21015       allocate(gradxorr(3,-1:nres))
21016       allocate(gradcorr5(3,-1:nres))
21017       allocate(gradcorr6(3,-1:nres))
21018       allocate(gliptran(3,-1:nres))
21019       allocate(gliptranc(3,-1:nres))
21020       allocate(gliptranx(3,-1:nres))
21021       allocate(gshieldx(3,-1:nres))
21022       allocate(gshieldc(3,-1:nres))
21023       allocate(gshieldc_loc(3,-1:nres))
21024       allocate(gshieldx_ec(3,-1:nres))
21025       allocate(gshieldc_ec(3,-1:nres))
21026       allocate(gshieldc_loc_ec(3,-1:nres))
21027       allocate(gshieldx_t3(3,-1:nres))
21028       allocate(gshieldc_t3(3,-1:nres))
21029       allocate(gshieldc_loc_t3(3,-1:nres))
21030       allocate(gshieldx_t4(3,-1:nres))
21031       allocate(gshieldc_t4(3,-1:nres))
21032       allocate(gshieldc_loc_t4(3,-1:nres))
21033       allocate(gshieldx_ll(3,-1:nres))
21034       allocate(gshieldc_ll(3,-1:nres))
21035       allocate(gshieldc_loc_ll(3,-1:nres))
21036       allocate(grad_shield(3,-1:nres))
21037       allocate(gg_tube_sc(3,-1:nres))
21038       allocate(gg_tube(3,-1:nres))
21039       allocate(gradafm(3,-1:nres))
21040       allocate(gradb_nucl(3,-1:nres))
21041       allocate(gradbx_nucl(3,-1:nres))
21042       allocate(gvdwpsb1(3,-1:nres))
21043       allocate(gelpp(3,-1:nres))
21044       allocate(gvdwpsb(3,-1:nres))
21045       allocate(gelsbc(3,-1:nres))
21046       allocate(gelsbx(3,-1:nres))
21047       allocate(gvdwsbx(3,-1:nres))
21048       allocate(gvdwsbc(3,-1:nres))
21049       allocate(gsbloc(3,-1:nres))
21050       allocate(gsblocx(3,-1:nres))
21051       allocate(gradcorr_nucl(3,-1:nres))
21052       allocate(gradxorr_nucl(3,-1:nres))
21053       allocate(gradcorr3_nucl(3,-1:nres))
21054       allocate(gradxorr3_nucl(3,-1:nres))
21055       allocate(gvdwpp_nucl(3,-1:nres))
21056       allocate(gradpepcat(3,-1:nres))
21057       allocate(gradpepcatx(3,-1:nres))
21058       allocate(gradcatcat(3,-1:nres))
21059       allocate(gradnuclcat(3,-1:nres))
21060       allocate(gradnuclcatx(3,-1:nres))
21061 !(3,maxres)
21062       allocate(grad_shield_side(3,maxcontsshi,-1:nres))
21063       allocate(grad_shield_loc(3,maxcontsshi,-1:nres))
21064 ! grad for shielding surroing
21065       allocate(gloc(0:maxvar,0:2))
21066       allocate(gloc_x(0:maxvar,2))
21067 !(maxvar,2)
21068       allocate(gel_loc(3,-1:nres))
21069       allocate(gel_loc_long(3,-1:nres))
21070       allocate(gcorr3_turn(3,-1:nres))
21071       allocate(gcorr4_turn(3,-1:nres))
21072       allocate(gcorr6_turn(3,-1:nres))
21073       allocate(gradb(3,-1:nres))
21074       allocate(gradbx(3,-1:nres))
21075 !(3,maxres)
21076       allocate(gel_loc_loc(maxvar))
21077       allocate(gel_loc_turn3(maxvar))
21078       allocate(gel_loc_turn4(maxvar))
21079       allocate(gel_loc_turn6(maxvar))
21080       allocate(gcorr_loc(maxvar))
21081       allocate(g_corr5_loc(maxvar))
21082       allocate(g_corr6_loc(maxvar))
21083 !(maxvar)
21084       allocate(gsccorc(3,-1:nres))
21085       allocate(gsccorx(3,-1:nres))
21086 !(3,maxres)
21087       allocate(gsccor_loc(-1:nres))
21088 !(maxres)
21089       allocate(gvdwx_scbase(3,-1:nres))
21090       allocate(gvdwc_scbase(3,-1:nres))
21091       allocate(gvdwx_pepbase(3,-1:nres))
21092       allocate(gvdwc_pepbase(3,-1:nres))
21093       allocate(gvdwx_scpho(3,-1:nres))
21094       allocate(gvdwc_scpho(3,-1:nres))
21095       allocate(gvdwc_peppho(3,-1:nres))
21096
21097       allocate(dtheta(3,2,-1:nres))
21098 !(3,2,maxres)
21099       allocate(gscloc(3,-1:nres))
21100       allocate(gsclocx(3,-1:nres))
21101 !(3,maxres)
21102       allocate(dphi(3,3,-1:nres))
21103       allocate(dalpha(3,3,-1:nres))
21104       allocate(domega(3,3,-1:nres))
21105 !(3,3,maxres)
21106 !      common /deriv_scloc/
21107       allocate(dXX_C1tab(3,nres))
21108       allocate(dYY_C1tab(3,nres))
21109       allocate(dZZ_C1tab(3,nres))
21110       allocate(dXX_Ctab(3,nres))
21111       allocate(dYY_Ctab(3,nres))
21112       allocate(dZZ_Ctab(3,nres))
21113       allocate(dXX_XYZtab(3,nres))
21114       allocate(dYY_XYZtab(3,nres))
21115       allocate(dZZ_XYZtab(3,nres))
21116 !(3,maxres)
21117 !      common /mpgrad/
21118       allocate(jgrad_start(nres))
21119       allocate(jgrad_end(nres))
21120 !(maxres)
21121 !----------------------
21122
21123 !      common /indices/
21124       allocate(ibond_displ(0:nfgtasks-1))
21125       allocate(ibond_count(0:nfgtasks-1))
21126       allocate(ithet_displ(0:nfgtasks-1))
21127       allocate(ithet_count(0:nfgtasks-1))
21128       allocate(iphi_displ(0:nfgtasks-1))
21129       allocate(iphi_count(0:nfgtasks-1))
21130       allocate(iphi1_displ(0:nfgtasks-1))
21131       allocate(iphi1_count(0:nfgtasks-1))
21132       allocate(ivec_displ(0:nfgtasks-1))
21133       allocate(ivec_count(0:nfgtasks-1))
21134       allocate(iset_displ(0:nfgtasks-1))
21135       allocate(iset_count(0:nfgtasks-1))
21136       allocate(iint_count(0:nfgtasks-1))
21137       allocate(iint_displ(0:nfgtasks-1))
21138 !(0:max_fg_procs-1)
21139 !----------------------
21140 ! common.MD
21141 !      common /mdgrad/
21142       allocate(gcart(3,-1:nres))
21143       allocate(gxcart(3,-1:nres))
21144 !(3,0:MAXRES)
21145       allocate(gradcag(3,-1:nres))
21146       allocate(gradxag(3,-1:nres))
21147 !(3,MAXRES)
21148 !      common /back_constr/
21149 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
21150       allocate(dutheta(nres))
21151       allocate(dugamma(nres))
21152 !(maxres)
21153       allocate(duscdiff(3,-1:nres))
21154       allocate(duscdiffx(3,-1:nres))
21155 !(3,maxres)
21156 !el i io:read_fragments
21157 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
21158 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
21159 !      common /qmeas/
21160 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
21161 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
21162       allocate(mset(0:nprocs))  !(maxprocs/20)
21163       mset(:)=0
21164 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
21165 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
21166       allocate(dUdconst(3,0:nres))
21167       allocate(dUdxconst(3,0:nres))
21168       allocate(dqwol(3,0:nres))
21169       allocate(dxqwol(3,0:nres))
21170 !(3,0:MAXRES)
21171 !----------------------
21172 ! common.sbridge
21173 !      common /sbridge/ in io_common: read_bridge
21174 !el    allocate((:),allocatable :: iss      !(maxss)
21175 !      common /links/  in io_common: read_bridge
21176 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
21177 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
21178 !      common /dyn_ssbond/
21179 ! and side-chain vectors in theta or phi.
21180       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
21181 !(maxres,maxres)
21182 !      do i=1,nres
21183 !        do j=i+1,nres
21184       dyn_ssbond_ij(:,:)=1.0d300
21185 !        enddo
21186 !      enddo
21187
21188 !      if (nss.gt.0) then
21189       allocate(idssb(maxdim),jdssb(maxdim))
21190 !        allocate(newihpb(nss),newjhpb(nss))
21191 !(maxdim)
21192 !      endif
21193       allocate(ishield_list(-1:nres))
21194       allocate(shield_list(maxcontsshi,-1:nres))
21195       allocate(dyn_ss_mask(nres))
21196       allocate(fac_shield(-1:nres))
21197       allocate(enetube(nres*2))
21198       allocate(enecavtube(nres*2))
21199
21200 !(maxres)
21201       dyn_ss_mask(:)=.false.
21202 !----------------------
21203 ! common.sccor
21204 ! Parameters of the SCCOR term
21205 !      common/sccor/
21206 !el in io_conf: parmread
21207 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
21208 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
21209 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
21210 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
21211 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
21212 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
21213 !      allocate(vlor1sccor(maxterm_sccor,20,20))
21214 !      allocate(vlor2sccor(maxterm_sccor,20,20))
21215 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
21216 !----------------
21217       allocate(gloc_sc(3,0:2*nres,0:10))
21218 !(3,0:maxres2,10)maxres2=2*maxres
21219       allocate(dcostau(3,3,3,2*nres))
21220       allocate(dsintau(3,3,3,2*nres))
21221       allocate(dtauangle(3,3,3,2*nres))
21222       allocate(dcosomicron(3,3,3,2*nres))
21223       allocate(domicron(3,3,3,2*nres))
21224 !(3,3,3,maxres2)maxres2=2*maxres
21225 !----------------------
21226 ! common.var
21227 !      common /restr/
21228       allocate(varall(maxvar))
21229 !(maxvar)(maxvar=6*maxres)
21230       allocate(mask_theta(nres))
21231       allocate(mask_phi(nres))
21232       allocate(mask_side(nres))
21233 !(maxres)
21234 !----------------------
21235 ! common.vectors
21236 !      common /vectors/
21237       allocate(uy(3,nres))
21238       allocate(uz(3,nres))
21239 !(3,maxres)
21240       allocate(uygrad(3,3,2,nres))
21241       allocate(uzgrad(3,3,2,nres))
21242 !(3,3,2,maxres)
21243 ! allocateion of lists JPRDLA
21244       allocate(newcontlistppi(300*nres))
21245       allocate(newcontlistscpi(300*nres))
21246       allocate(newcontlisti(300*nres))
21247       allocate(newcontlistppj(300*nres))
21248       allocate(newcontlistscpj(300*nres))
21249       allocate(newcontlistj(300*nres))
21250
21251       return
21252       end subroutine alloc_ener_arrays
21253 !-----------------------------------------------------------------
21254       subroutine ebond_nucl(estr_nucl)
21255 !c
21256 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
21257 !c
21258
21259       real(kind=8),dimension(3) :: u,ud
21260       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
21261       real(kind=8) :: estr_nucl,diff
21262       integer :: iti,i,j,k,nbi
21263       estr_nucl=0.0d0
21264 !C      print *,"I enter ebond"
21265       if (energy_dec) &
21266       write (iout,*) "ibondp_start,ibondp_end",&
21267        ibondp_nucl_start,ibondp_nucl_end
21268       do i=ibondp_nucl_start,ibondp_nucl_end
21269       if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
21270        itype(i,2).eq.ntyp1_molec(2)) cycle
21271 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
21272 !          do j=1,3
21273 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
21274 !     &      *dc(j,i-1)/vbld(i)
21275 !          enddo
21276 !          if (energy_dec) write(iout,*)
21277 !     &       "estr1",i,vbld(i),distchainmax,
21278 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
21279
21280         diff = vbld(i)-vbldp0_nucl
21281         if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
21282         vbldp0_nucl,diff,AKP_nucl*diff*diff
21283         estr_nucl=estr_nucl+diff*diff
21284 !          print *,estr_nucl
21285         do j=1,3
21286           gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
21287         enddo
21288 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
21289       enddo
21290       estr_nucl=0.5d0*AKP_nucl*estr_nucl
21291 !      print *,"partial sum", estr_nucl,AKP_nucl
21292
21293       if (energy_dec) &
21294       write (iout,*) "ibondp_start,ibondp_end",&
21295        ibond_nucl_start,ibond_nucl_end
21296
21297       do i=ibond_nucl_start,ibond_nucl_end
21298 !C        print *, "I am stuck",i
21299       iti=itype(i,2)
21300       if (iti.eq.ntyp1_molec(2)) cycle
21301         nbi=nbondterm_nucl(iti)
21302 !C        print *,iti,nbi
21303         if (nbi.eq.1) then
21304           diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
21305
21306           if (energy_dec) &
21307          write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
21308          AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
21309           estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
21310 !            print *,estr_nucl
21311           do j=1,3
21312             gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
21313           enddo
21314         else
21315           do j=1,nbi
21316             diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
21317             ud(j)=aksc_nucl(j,iti)*diff
21318             u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
21319           enddo
21320           uprod=u(1)
21321           do j=2,nbi
21322             uprod=uprod*u(j)
21323           enddo
21324           usum=0.0d0
21325           usumsqder=0.0d0
21326           do j=1,nbi
21327             uprod1=1.0d0
21328             uprod2=1.0d0
21329             do k=1,nbi
21330             if (k.ne.j) then
21331               uprod1=uprod1*u(k)
21332               uprod2=uprod2*u(k)*u(k)
21333             endif
21334             enddo
21335             usum=usum+uprod1
21336             usumsqder=usumsqder+ud(j)*uprod2
21337           enddo
21338           estr_nucl=estr_nucl+uprod/usum
21339           do j=1,3
21340            gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
21341           enddo
21342       endif
21343       enddo
21344 !C      print *,"I am about to leave ebond"
21345       return
21346       end subroutine ebond_nucl
21347
21348 !-----------------------------------------------------------------------------
21349       subroutine ebend_nucl(etheta_nucl)
21350       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
21351       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
21352       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
21353       logical :: lprn=.false., lprn1=.false.
21354 !el local variables
21355       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
21356       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
21357       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
21358 ! local variables for constrains
21359       real(kind=8) :: difi,thetiii
21360        integer itheta
21361       etheta_nucl=0.0D0
21362 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
21363       do i=ithet_nucl_start,ithet_nucl_end
21364       if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
21365       (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
21366       (itype(i,2).eq.ntyp1_molec(2))) cycle
21367       dethetai=0.0d0
21368       dephii=0.0d0
21369       dephii1=0.0d0
21370       theti2=0.5d0*theta(i)
21371       ityp2=ithetyp_nucl(itype(i-1,2))
21372       do k=1,nntheterm_nucl
21373         coskt(k)=dcos(k*theti2)
21374         sinkt(k)=dsin(k*theti2)
21375       enddo
21376       if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
21377 #ifdef OSF
21378         phii=phi(i)
21379         if (phii.ne.phii) phii=150.0
21380 #else
21381         phii=phi(i)
21382 #endif
21383         ityp1=ithetyp_nucl(itype(i-2,2))
21384         do k=1,nsingle_nucl
21385           cosph1(k)=dcos(k*phii)
21386           sinph1(k)=dsin(k*phii)
21387         enddo
21388       else
21389         phii=0.0d0
21390         ityp1=nthetyp_nucl+1
21391         do k=1,nsingle_nucl
21392           cosph1(k)=0.0d0
21393           sinph1(k)=0.0d0
21394         enddo
21395       endif
21396
21397       if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
21398 #ifdef OSF
21399         phii1=phi(i+1)
21400         if (phii1.ne.phii1) phii1=150.0
21401         phii1=pinorm(phii1)
21402 #else
21403         phii1=phi(i+1)
21404 #endif
21405         ityp3=ithetyp_nucl(itype(i,2))
21406         do k=1,nsingle_nucl
21407           cosph2(k)=dcos(k*phii1)
21408           sinph2(k)=dsin(k*phii1)
21409         enddo
21410       else
21411         phii1=0.0d0
21412         ityp3=nthetyp_nucl+1
21413         do k=1,nsingle_nucl
21414           cosph2(k)=0.0d0
21415           sinph2(k)=0.0d0
21416         enddo
21417       endif
21418       ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
21419       do k=1,ndouble_nucl
21420         do l=1,k-1
21421           ccl=cosph1(l)*cosph2(k-l)
21422           ssl=sinph1(l)*sinph2(k-l)
21423           scl=sinph1(l)*cosph2(k-l)
21424           csl=cosph1(l)*sinph2(k-l)
21425           cosph1ph2(l,k)=ccl-ssl
21426           cosph1ph2(k,l)=ccl+ssl
21427           sinph1ph2(l,k)=scl+csl
21428           sinph1ph2(k,l)=scl-csl
21429         enddo
21430       enddo
21431       if (lprn) then
21432       write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
21433        " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
21434       write (iout,*) "coskt and sinkt",nntheterm_nucl
21435       do k=1,nntheterm_nucl
21436         write (iout,*) k,coskt(k),sinkt(k)
21437       enddo
21438       endif
21439       do k=1,ntheterm_nucl
21440         ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
21441         dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
21442          *coskt(k)
21443         if (lprn)&
21444        write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
21445         " ethetai",ethetai
21446       enddo
21447       if (lprn) then
21448       write (iout,*) "cosph and sinph"
21449       do k=1,nsingle_nucl
21450         write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
21451       enddo
21452       write (iout,*) "cosph1ph2 and sinph2ph2"
21453       do k=2,ndouble_nucl
21454         do l=1,k-1
21455           write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
21456             sinph1ph2(l,k),sinph1ph2(k,l)
21457         enddo
21458       enddo
21459       write(iout,*) "ethetai",ethetai
21460       endif
21461       do m=1,ntheterm2_nucl
21462         do k=1,nsingle_nucl
21463           aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
21464             +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
21465             +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
21466             +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
21467           ethetai=ethetai+sinkt(m)*aux
21468           dethetai=dethetai+0.5d0*m*aux*coskt(m)
21469           dephii=dephii+k*sinkt(m)*(&
21470              ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
21471              bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
21472           dephii1=dephii1+k*sinkt(m)*(&
21473              eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
21474              ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
21475           if (lprn) &
21476          write (iout,*) "m",m," k",k," bbthet",&
21477             bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
21478             ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
21479             ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
21480             eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
21481         enddo
21482       enddo
21483       if (lprn) &
21484       write(iout,*) "ethetai",ethetai
21485       do m=1,ntheterm3_nucl
21486         do k=2,ndouble_nucl
21487           do l=1,k-1
21488             aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
21489              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
21490              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
21491              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
21492             ethetai=ethetai+sinkt(m)*aux
21493             dethetai=dethetai+0.5d0*m*coskt(m)*aux
21494             dephii=dephii+l*sinkt(m)*(&
21495             -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
21496              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
21497              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
21498              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
21499             dephii1=dephii1+(k-l)*sinkt(m)*( &
21500             -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
21501              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
21502              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
21503              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
21504             if (lprn) then
21505             write (iout,*) "m",m," k",k," l",l," ffthet", &
21506              ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
21507              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
21508              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
21509              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
21510             write (iout,*) cosph1ph2(l,k)*sinkt(m), &
21511              cosph1ph2(k,l)*sinkt(m),&
21512              sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
21513             endif
21514           enddo
21515         enddo
21516       enddo
21517 10      continue
21518       if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
21519       i,theta(i)*rad2deg,phii*rad2deg, &
21520       phii1*rad2deg,ethetai
21521       etheta_nucl=etheta_nucl+ethetai
21522 !        print *,i,"partial sum",etheta_nucl
21523       if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
21524       if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
21525       gloc(nphi+i-2,icg)=wang_nucl*dethetai
21526       enddo
21527       return
21528       end subroutine ebend_nucl
21529 !----------------------------------------------------
21530       subroutine etor_nucl(etors_nucl)
21531 !      implicit real*8 (a-h,o-z)
21532 !      include 'DIMENSIONS'
21533 !      include 'COMMON.VAR'
21534 !      include 'COMMON.GEO'
21535 !      include 'COMMON.LOCAL'
21536 !      include 'COMMON.TORSION'
21537 !      include 'COMMON.INTERACT'
21538 !      include 'COMMON.DERIV'
21539 !      include 'COMMON.CHAIN'
21540 !      include 'COMMON.NAMES'
21541 !      include 'COMMON.IOUNITS'
21542 !      include 'COMMON.FFIELD'
21543 !      include 'COMMON.TORCNSTR'
21544 !      include 'COMMON.CONTROL'
21545       real(kind=8) :: etors_nucl,edihcnstr
21546       logical :: lprn
21547 !el local variables
21548       integer :: i,j,iblock,itori,itori1
21549       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
21550                vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
21551 ! Set lprn=.true. for debugging
21552       lprn=.false.
21553 !     lprn=.true.
21554       etors_nucl=0.0D0
21555 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
21556       do i=iphi_nucl_start,iphi_nucl_end
21557       if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
21558            .or. itype(i-3,2).eq.ntyp1_molec(2) &
21559            .or. itype(i,2).eq.ntyp1_molec(2)) cycle
21560       etors_ii=0.0D0
21561       itori=itortyp_nucl(itype(i-2,2))
21562       itori1=itortyp_nucl(itype(i-1,2))
21563       phii=phi(i)
21564 !         print *,i,itori,itori1
21565       gloci=0.0D0
21566 !C Regular cosine and sine terms
21567       do j=1,nterm_nucl(itori,itori1)
21568         v1ij=v1_nucl(j,itori,itori1)
21569         v2ij=v2_nucl(j,itori,itori1)
21570         cosphi=dcos(j*phii)
21571         sinphi=dsin(j*phii)
21572         etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
21573         if (energy_dec) etors_ii=etors_ii+&
21574                  v1ij*cosphi+v2ij*sinphi
21575         gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
21576       enddo
21577 !C Lorentz terms
21578 !C                         v1
21579 !C  E = SUM ----------------------------------- - v1
21580 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
21581 !C
21582       cosphi=dcos(0.5d0*phii)
21583       sinphi=dsin(0.5d0*phii)
21584       do j=1,nlor_nucl(itori,itori1)
21585         vl1ij=vlor1_nucl(j,itori,itori1)
21586         vl2ij=vlor2_nucl(j,itori,itori1)
21587         vl3ij=vlor3_nucl(j,itori,itori1)
21588         pom=vl2ij*cosphi+vl3ij*sinphi
21589         pom1=1.0d0/(pom*pom+1.0d0)
21590         etors_nucl=etors_nucl+vl1ij*pom1
21591         if (energy_dec) etors_ii=etors_ii+ &
21592                  vl1ij*pom1
21593         pom=-pom*pom1*pom1
21594         gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
21595       enddo
21596 !C Subtract the constant term
21597       etors_nucl=etors_nucl-v0_nucl(itori,itori1)
21598         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
21599             'etor',i,etors_ii-v0_nucl(itori,itori1)
21600       if (lprn) &
21601        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
21602        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
21603        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
21604       gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
21605 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
21606       enddo
21607       return
21608       end subroutine etor_nucl
21609 !------------------------------------------------------------
21610       subroutine epp_nucl_sub(evdw1,ees)
21611 !C
21612 !C This subroutine calculates the average interaction energy and its gradient
21613 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
21614 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
21615 !C The potential depends both on the distance of peptide-group centers and on
21616 !C the orientation of the CA-CA virtual bonds.
21617 !C
21618       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
21619       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbbi,sslipi,ssgradlipi, &
21620                       sslipj,ssgradlipj,faclipij2
21621       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
21622              dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
21623              dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
21624       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21625                 dist_temp, dist_init,sss_grad,fac,evdw1ij
21626       integer xshift,yshift,zshift
21627       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
21628       real(kind=8) :: ees,eesij
21629 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21630       real(kind=8) scal_el /0.5d0/
21631       t_eelecij=0.0d0
21632       ees=0.0D0
21633       evdw1=0.0D0
21634       ind=0
21635 !c
21636 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
21637 !c
21638 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
21639       do i=iatel_s_nucl,iatel_e_nucl
21640       if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21641       dxi=dc(1,i)
21642       dyi=dc(2,i)
21643       dzi=dc(3,i)
21644       dx_normi=dc_norm(1,i)
21645       dy_normi=dc_norm(2,i)
21646       dz_normi=dc_norm(3,i)
21647       xmedi=c(1,i)+0.5d0*dxi
21648       ymedi=c(2,i)+0.5d0*dyi
21649       zmedi=c(3,i)+0.5d0*dzi
21650         call to_box(xmedi,ymedi,zmedi)
21651         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
21652
21653       do j=ielstart_nucl(i),ielend_nucl(i)
21654         if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
21655         ind=ind+1
21656         dxj=dc(1,j)
21657         dyj=dc(2,j)
21658         dzj=dc(3,j)
21659 !          xj=c(1,j)+0.5D0*dxj-xmedi
21660 !          yj=c(2,j)+0.5D0*dyj-ymedi
21661 !          zj=c(3,j)+0.5D0*dzj-zmedi
21662         xj=c(1,j)+0.5D0*dxj
21663         yj=c(2,j)+0.5D0*dyj
21664         zj=c(3,j)+0.5D0*dzj
21665      call to_box(xj,yj,zj)
21666      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
21667       faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
21668       xj=boxshift(xj-xmedi,boxxsize)
21669       yj=boxshift(yj-ymedi,boxysize)
21670       zj=boxshift(zj-zmedi,boxzsize)
21671         rij=xj*xj+yj*yj+zj*zj
21672 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
21673         fac=(r0pp**2/rij)**3
21674         ev1=epspp*fac*fac
21675         ev2=epspp*fac
21676         evdw1ij=ev1-2*ev2
21677         fac=(-ev1-evdw1ij)/rij
21678 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
21679         if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
21680         evdw1=evdw1+evdw1ij
21681 !C
21682 !C Calculate contributions to the Cartesian gradient.
21683 !C
21684         ggg(1)=fac*xj
21685         ggg(2)=fac*yj
21686         ggg(3)=fac*zj
21687         do k=1,3
21688           gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
21689           gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
21690         enddo
21691 !c phoshate-phosphate electrostatic interactions
21692         rij=dsqrt(rij)
21693         fac=1.0d0/rij
21694         eesij=dexp(-BEES*rij)*fac
21695 !          write (2,*)"fac",fac," eesijpp",eesij
21696         if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
21697         ees=ees+eesij
21698 !c          fac=-eesij*fac
21699         fac=-(fac+BEES)*eesij*fac
21700         ggg(1)=fac*xj
21701         ggg(2)=fac*yj
21702         ggg(3)=fac*zj
21703 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
21704 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
21705 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
21706         do k=1,3
21707           gelpp(k,i)=gelpp(k,i)-ggg(k)
21708           gelpp(k,j)=gelpp(k,j)+ggg(k)
21709         enddo
21710       enddo ! j
21711       enddo   ! i
21712 !c      ees=332.0d0*ees
21713       ees=AEES*ees
21714       do i=nnt,nct
21715 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21716       do k=1,3
21717         gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
21718 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
21719         gelpp(k,i)=AEES*gelpp(k,i)
21720       enddo
21721 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21722       enddo
21723 !c      write (2,*) "total EES",ees
21724       return
21725       end subroutine epp_nucl_sub
21726 !---------------------------------------------------------------------
21727       subroutine epsb(evdwpsb,eelpsb)
21728 !      use comm_locel
21729 !C
21730 !C This subroutine calculates the excluded-volume interaction energy between
21731 !C peptide-group centers and side chains and its gradient in virtual-bond and
21732 !C side-chain vectors.
21733 !C
21734       real(kind=8),dimension(3):: ggg
21735       integer :: i,iint,j,k,iteli,itypj,subchap
21736       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
21737                e1,e2,evdwij,rij,evdwpsb,eelpsb
21738       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21739                 dist_temp, dist_init
21740       integer xshift,yshift,zshift
21741
21742 !cd    print '(a)','Enter ESCP'
21743 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
21744       eelpsb=0.0d0
21745       evdwpsb=0.0d0
21746 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
21747       do i=iatscp_s_nucl,iatscp_e_nucl
21748       if (itype(i,2).eq.ntyp1_molec(2) &
21749        .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21750       xi=0.5D0*(c(1,i)+c(1,i+1))
21751       yi=0.5D0*(c(2,i)+c(2,i+1))
21752       zi=0.5D0*(c(3,i)+c(3,i+1))
21753         call to_box(xi,yi,zi)
21754
21755       do iint=1,nscp_gr_nucl(i)
21756
21757       do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
21758         itypj=itype(j,2)
21759         if (itypj.eq.ntyp1_molec(2)) cycle
21760 !C Uncomment following three lines for SC-p interactions
21761 !c         xj=c(1,nres+j)-xi
21762 !c         yj=c(2,nres+j)-yi
21763 !c         zj=c(3,nres+j)-zi
21764 !C Uncomment following three lines for Ca-p interactions
21765 !          xj=c(1,j)-xi
21766 !          yj=c(2,j)-yi
21767 !          zj=c(3,j)-zi
21768         xj=c(1,j)
21769         yj=c(2,j)
21770         zj=c(3,j)
21771         call to_box(xj,yj,zj)
21772       xj=boxshift(xj-xi,boxxsize)
21773       yj=boxshift(yj-yi,boxysize)
21774       zj=boxshift(zj-zi,boxzsize)
21775
21776       dist_init=xj**2+yj**2+zj**2
21777
21778         rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21779         fac=rrij**expon2
21780         e1=fac*fac*aad_nucl(itypj)
21781         e2=fac*bad_nucl(itypj)
21782         if (iabs(j-i) .le. 2) then
21783           e1=scal14*e1
21784           e2=scal14*e2
21785         endif
21786         evdwij=e1+e2
21787         evdwpsb=evdwpsb+evdwij
21788         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
21789            'evdw2',i,j,evdwij,"tu4"
21790 !C
21791 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
21792 !C
21793         fac=-(evdwij+e1)*rrij
21794         ggg(1)=xj*fac
21795         ggg(2)=yj*fac
21796         ggg(3)=zj*fac
21797         do k=1,3
21798           gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
21799           gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
21800         enddo
21801       enddo
21802
21803       enddo ! iint
21804       enddo ! i
21805       do i=1,nct
21806       do j=1,3
21807         gvdwpsb(j,i)=expon*gvdwpsb(j,i)
21808         gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
21809       enddo
21810       enddo
21811       return
21812       end subroutine epsb
21813
21814 !------------------------------------------------------
21815       subroutine esb_gb(evdwsb,eelsb)
21816       use comm_locel
21817       use calc_data_nucl
21818       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
21819       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
21820       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
21821       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21822                 dist_temp, dist_init,aa,bb,faclip,sig0ij
21823       integer :: ii
21824       logical lprn
21825       evdw=0.0D0
21826       eelsb=0.0d0
21827       ecorr=0.0d0
21828       evdwsb=0.0D0
21829       lprn=.false.
21830       ind=0
21831 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
21832       do i=iatsc_s_nucl,iatsc_e_nucl
21833       num_conti=0
21834       num_conti2=0
21835       itypi=itype(i,2)
21836 !        PRINT *,"I=",i,itypi
21837       if (itypi.eq.ntyp1_molec(2)) cycle
21838       itypi1=itype(i+1,2)
21839       xi=c(1,nres+i)
21840       yi=c(2,nres+i)
21841       zi=c(3,nres+i)
21842       call to_box(xi,yi,zi)
21843       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
21844       dxi=dc_norm(1,nres+i)
21845       dyi=dc_norm(2,nres+i)
21846       dzi=dc_norm(3,nres+i)
21847       dsci_inv=vbld_inv(i+nres)
21848 !C
21849 !C Calculate SC interaction energy.
21850 !C
21851       do iint=1,nint_gr_nucl(i)
21852 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
21853         do j=istart_nucl(i,iint),iend_nucl(i,iint)
21854           ind=ind+1
21855 !            print *,"JESTEM"
21856           itypj=itype(j,2)
21857           if (itypj.eq.ntyp1_molec(2)) cycle
21858           dscj_inv=vbld_inv(j+nres)
21859           sig0ij=sigma_nucl(itypi,itypj)
21860           chi1=chi_nucl(itypi,itypj)
21861           chi2=chi_nucl(itypj,itypi)
21862           chi12=chi1*chi2
21863           chip1=chip_nucl(itypi,itypj)
21864           chip2=chip_nucl(itypj,itypi)
21865           chip12=chip1*chip2
21866 !            xj=c(1,nres+j)-xi
21867 !            yj=c(2,nres+j)-yi
21868 !            zj=c(3,nres+j)-zi
21869          xj=c(1,nres+j)
21870          yj=c(2,nres+j)
21871          zj=c(3,nres+j)
21872      call to_box(xj,yj,zj)
21873 !     call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
21874 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
21875 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
21876 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
21877 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
21878       xj=boxshift(xj-xi,boxxsize)
21879       yj=boxshift(yj-yi,boxysize)
21880       zj=boxshift(zj-zi,boxzsize)
21881
21882           dxj=dc_norm(1,nres+j)
21883           dyj=dc_norm(2,nres+j)
21884           dzj=dc_norm(3,nres+j)
21885           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21886           rij=dsqrt(rrij)
21887 !C Calculate angle-dependent terms of energy and contributions to their
21888 !C derivatives.
21889           erij(1)=xj*rij
21890           erij(2)=yj*rij
21891           erij(3)=zj*rij
21892           om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
21893           om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
21894           om12=dxi*dxj+dyi*dyj+dzi*dzj
21895           call sc_angular_nucl
21896           sigsq=1.0D0/sigsq
21897           sig=sig0ij*dsqrt(sigsq)
21898           rij_shift=1.0D0/rij-sig+sig0ij
21899 !            print *,rij_shift,"rij_shift"
21900 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
21901 !c     &       " rij_shift",rij_shift
21902           if (rij_shift.le.0.0D0) then
21903             evdw=1.0D20
21904             return
21905           endif
21906           sigder=-sig*sigsq
21907 !c---------------------------------------------------------------
21908           rij_shift=1.0D0/rij_shift
21909           fac=rij_shift**expon
21910           e1=fac*fac*aa_nucl(itypi,itypj)
21911           e2=fac*bb_nucl(itypi,itypj)
21912           evdwij=eps1*eps2rt*(e1+e2)
21913 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
21914 !c     &       " e1",e1," e2",e2," evdwij",evdwij
21915           eps2der=evdwij
21916           evdwij=evdwij*eps2rt
21917           evdwsb=evdwsb+evdwij
21918           if (lprn) then
21919           sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
21920           epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
21921           write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
21922            restyp(itypi,2),i,restyp(itypj,2),j, &
21923            epsi,sigm,chi1,chi2,chip1,chip2, &
21924            eps1,eps2rt**2,sig,sig0ij, &
21925            om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
21926           evdwij
21927           write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
21928           endif
21929
21930           if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
21931                        'evdw',i,j,evdwij,"tu3"
21932
21933
21934 !C Calculate gradient components.
21935           e1=e1*eps1*eps2rt**2
21936           fac=-expon*(e1+evdwij)*rij_shift
21937           sigder=fac*sigder
21938           fac=rij*fac
21939 !c            fac=0.0d0
21940 !C Calculate the radial part of the gradient
21941           gg(1)=xj*fac
21942           gg(2)=yj*fac
21943           gg(3)=zj*fac
21944 !C Calculate angular part of the gradient.
21945           call sc_grad_nucl
21946           call eelsbij(eelij,num_conti2)
21947           if (energy_dec .and. &
21948          (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
21949         write (istat,'(e14.5)') evdwij
21950           eelsb=eelsb+eelij
21951         enddo      ! j
21952       enddo        ! iint
21953       num_cont_hb(i)=num_conti2
21954       enddo          ! i
21955 !c      write (iout,*) "Number of loop steps in EGB:",ind
21956 !cccc      energy_dec=.false.
21957       return
21958       end subroutine esb_gb
21959 !-------------------------------------------------------------------------------
21960       subroutine eelsbij(eesij,num_conti2)
21961       use comm_locel
21962       use calc_data_nucl
21963       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
21964       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
21965       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21966                 dist_temp, dist_init,rlocshield,fracinbuf
21967       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
21968
21969 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21970       real(kind=8) scal_el /0.5d0/
21971       integer :: iteli,itelj,kkk,kkll,m,isubchap
21972       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
21973       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
21974       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
21975               r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
21976               el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
21977               ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
21978               a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
21979               ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
21980               ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
21981               ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
21982       ind=ind+1
21983       itypi=itype(i,2)
21984       itypj=itype(j,2)
21985 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
21986       ael6i=ael6_nucl(itypi,itypj)
21987       ael3i=ael3_nucl(itypi,itypj)
21988       ael63i=ael63_nucl(itypi,itypj)
21989       ael32i=ael32_nucl(itypi,itypj)
21990 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
21991 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
21992       dxj=dc(1,j+nres)
21993       dyj=dc(2,j+nres)
21994       dzj=dc(3,j+nres)
21995       dx_normi=dc_norm(1,i+nres)
21996       dy_normi=dc_norm(2,i+nres)
21997       dz_normi=dc_norm(3,i+nres)
21998       dx_normj=dc_norm(1,j+nres)
21999       dy_normj=dc_norm(2,j+nres)
22000       dz_normj=dc_norm(3,j+nres)
22001 !c      xj=c(1,j)+0.5D0*dxj-xmedi
22002 !c      yj=c(2,j)+0.5D0*dyj-ymedi
22003 !c      zj=c(3,j)+0.5D0*dzj-zmedi
22004       if (ipot_nucl.ne.2) then
22005       cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
22006       cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
22007       cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
22008       else
22009       cosa=om12
22010       cosb=om1
22011       cosg=om2
22012       endif
22013       r3ij=rij*rrij
22014       r6ij=r3ij*r3ij
22015       fac=cosa-3.0D0*cosb*cosg
22016       facfac=fac*fac
22017       fac1=3.0d0*(cosb*cosb+cosg*cosg)
22018       fac3=ael6i*r6ij
22019       fac4=ael3i*r3ij
22020       fac5=ael63i*r6ij
22021       fac6=ael32i*r6ij
22022 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
22023 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
22024       el1=fac3*(4.0D0+facfac-fac1)
22025       el2=fac4*fac
22026       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
22027       el4=fac6*facfac
22028       eesij=el1+el2+el3+el4
22029 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
22030       ees0ij=4.0D0+facfac-fac1
22031
22032       if (energy_dec) then
22033         if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
22034         write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
22035          sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
22036          restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
22037          (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
22038         write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
22039       endif
22040
22041 !C
22042 !C Calculate contributions to the Cartesian gradient.
22043 !C
22044       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
22045       fac1=fac
22046 !c      erij(1)=xj*rmij
22047 !c      erij(2)=yj*rmij
22048 !c      erij(3)=zj*rmij
22049 !*
22050 !* Radial derivatives. First process both termini of the fragment (i,j)
22051 !*
22052       ggg(1)=facel*xj
22053       ggg(2)=facel*yj
22054       ggg(3)=facel*zj
22055       do k=1,3
22056       gelsbc(k,j)=gelsbc(k,j)+ggg(k)
22057       gelsbc(k,i)=gelsbc(k,i)-ggg(k)
22058       gelsbx(k,j)=gelsbx(k,j)+ggg(k)
22059       gelsbx(k,i)=gelsbx(k,i)-ggg(k)
22060       enddo
22061 !*
22062 !* Angular part
22063 !*
22064       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
22065       fac4=-3.0D0*fac4
22066       fac3=-6.0D0*fac3
22067       fac5= 6.0d0*fac5
22068       fac6=-6.0d0*fac6
22069       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
22070        fac6*fac1*cosg
22071       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
22072        fac6*fac1*cosb
22073       do k=1,3
22074       dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
22075       dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
22076       enddo
22077       do k=1,3
22078       ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
22079       enddo
22080       do k=1,3
22081       gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
22082            +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
22083            + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
22084       gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
22085            +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
22086            + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
22087       gelsbc(k,j)=gelsbc(k,j)+ggg(k)
22088       gelsbc(k,i)=gelsbc(k,i)-ggg(k)
22089       enddo
22090 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
22091        IF ( j.gt.i+1 .and.&
22092         num_conti.le.maxcont) THEN
22093 !C
22094 !C Calculate the contact function. The ith column of the array JCONT will
22095 !C contain the numbers of atoms that make contacts with the atom I (of numbers
22096 !C greater than I). The arrays FACONT and GACONT will contain the values of
22097 !C the contact function and its derivative.
22098       r0ij=2.20D0*sigma_nucl(itypi,itypj)
22099 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
22100       call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
22101 !c        write (2,*) "fcont",fcont
22102       if (fcont.gt.0.0D0) then
22103         num_conti=num_conti+1
22104         num_conti2=num_conti2+1
22105
22106         if (num_conti.gt.maxconts) then
22107           write (iout,*) 'WARNING - max. # of contacts exceeded;',&
22108                     ' will skip next contacts for this conf.',maxconts
22109         else
22110           jcont_hb(num_conti,i)=j
22111 !c            write (iout,*) "num_conti",num_conti,
22112 !c     &        " jcont_hb",jcont_hb(num_conti,i)
22113 !C Calculate contact energies
22114           cosa4=4.0D0*cosa
22115           wij=cosa-3.0D0*cosb*cosg
22116           cosbg1=cosb+cosg
22117           cosbg2=cosb-cosg
22118           fac3=dsqrt(-ael6i)*r3ij
22119 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
22120           ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
22121           if (ees0tmp.gt.0) then
22122             ees0pij=dsqrt(ees0tmp)
22123           else
22124             ees0pij=0
22125           endif
22126           ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
22127           if (ees0tmp.gt.0) then
22128             ees0mij=dsqrt(ees0tmp)
22129           else
22130             ees0mij=0
22131           endif
22132           ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
22133           ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
22134 !c            write (iout,*) "i",i," j",j,
22135 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
22136           ees0pij1=fac3/ees0pij
22137           ees0mij1=fac3/ees0mij
22138           fac3p=-3.0D0*fac3*rrij
22139           ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
22140           ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
22141           ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
22142           ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
22143           ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
22144           ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
22145           ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
22146           ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
22147           ecosap=ecosa1+ecosa2
22148           ecosbp=ecosb1+ecosb2
22149           ecosgp=ecosg1+ecosg2
22150           ecosam=ecosa1-ecosa2
22151           ecosbm=ecosb1-ecosb2
22152           ecosgm=ecosg1-ecosg2
22153 !C End diagnostics
22154           facont_hb(num_conti,i)=fcont
22155           fprimcont=fprimcont/rij
22156           do k=1,3
22157             gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
22158             gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
22159           enddo
22160           gggp(1)=gggp(1)+ees0pijp*xj
22161           gggp(2)=gggp(2)+ees0pijp*yj
22162           gggp(3)=gggp(3)+ees0pijp*zj
22163           gggm(1)=gggm(1)+ees0mijp*xj
22164           gggm(2)=gggm(2)+ees0mijp*yj
22165           gggm(3)=gggm(3)+ees0mijp*zj
22166 !C Derivatives due to the contact function
22167           gacont_hbr(1,num_conti,i)=fprimcont*xj
22168           gacont_hbr(2,num_conti,i)=fprimcont*yj
22169           gacont_hbr(3,num_conti,i)=fprimcont*zj
22170           do k=1,3
22171 !c
22172 !c Gradient of the correlation terms
22173 !c
22174             gacontp_hb1(k,num_conti,i)= &
22175            (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
22176           + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
22177             gacontp_hb2(k,num_conti,i)= &
22178            (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
22179           + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
22180             gacontp_hb3(k,num_conti,i)=gggp(k)
22181             gacontm_hb1(k,num_conti,i)= &
22182            (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
22183           + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
22184             gacontm_hb2(k,num_conti,i)= &
22185            (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
22186           + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
22187             gacontm_hb3(k,num_conti,i)=gggm(k)
22188           enddo
22189         endif
22190       endif
22191       ENDIF
22192       return
22193       end subroutine eelsbij
22194 !------------------------------------------------------------------
22195       subroutine sc_grad_nucl
22196       use comm_locel
22197       use calc_data_nucl
22198       real(kind=8),dimension(3) :: dcosom1,dcosom2
22199       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
22200       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
22201       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
22202       do k=1,3
22203       dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
22204       dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
22205       enddo
22206       do k=1,3
22207       gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
22208       enddo
22209       do k=1,3
22210       gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
22211              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
22212              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
22213       gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
22214              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22215              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22216       enddo
22217 !C
22218 !C Calculate the components of the gradient in DC and X
22219 !C
22220       do l=1,3
22221       gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
22222       gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
22223       enddo
22224       return
22225       end subroutine sc_grad_nucl
22226 !-----------------------------------------------------------------------
22227       subroutine esb(esbloc)
22228 !C Calculate the local energy of a side chain and its derivatives in the
22229 !C corresponding virtual-bond valence angles THETA and the spherical angles
22230 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
22231 !C added by Urszula Kozlowska. 07/11/2007
22232 !C
22233       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
22234       real(kind=8),dimension(9):: x
22235      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
22236       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
22237       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
22238       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
22239        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
22240        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
22241        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
22242        integer::it,nlobit,i,j,k
22243 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
22244       delta=0.02d0*pi
22245       esbloc=0.0D0
22246       do i=loc_start_nucl,loc_end_nucl
22247       if (itype(i,2).eq.ntyp1_molec(2)) cycle
22248       costtab(i+1) =dcos(theta(i+1))
22249       sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
22250       cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
22251       sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
22252       cosfac2=0.5d0/(1.0d0+costtab(i+1))
22253       cosfac=dsqrt(cosfac2)
22254       sinfac2=0.5d0/(1.0d0-costtab(i+1))
22255       sinfac=dsqrt(sinfac2)
22256       it=itype(i,2)
22257       if (it.eq.10) goto 1
22258
22259 !c
22260 !C  Compute the axes of tghe local cartesian coordinates system; store in
22261 !c   x_prime, y_prime and z_prime
22262 !c
22263       do j=1,3
22264         x_prime(j) = 0.00
22265         y_prime(j) = 0.00
22266         z_prime(j) = 0.00
22267       enddo
22268 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
22269 !C     &   dc_norm(3,i+nres)
22270       do j = 1,3
22271         x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
22272         y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
22273       enddo
22274       do j = 1,3
22275         z_prime(j) = -uz(j,i-1)
22276 !           z_prime(j)=0.0
22277       enddo
22278
22279       xx=0.0d0
22280       yy=0.0d0
22281       zz=0.0d0
22282       do j = 1,3
22283         xx = xx + x_prime(j)*dc_norm(j,i+nres)
22284         yy = yy + y_prime(j)*dc_norm(j,i+nres)
22285         zz = zz + z_prime(j)*dc_norm(j,i+nres)
22286       enddo
22287
22288       xxtab(i)=xx
22289       yytab(i)=yy
22290       zztab(i)=zz
22291        it=itype(i,2)
22292       do j = 1,9
22293         x(j) = sc_parmin_nucl(j,it)
22294       enddo
22295 #ifdef CHECK_COORD
22296 !Cc diagnostics - remove later
22297       xx1 = dcos(alph(2))
22298       yy1 = dsin(alph(2))*dcos(omeg(2))
22299       zz1 = -dsin(alph(2))*dsin(omeg(2))
22300       write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
22301        alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
22302        xx1,yy1,zz1
22303 !C,"  --- ", xx_w,yy_w,zz_w
22304 !c end diagnostics
22305 #endif
22306       sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22307       esbloc = esbloc + sumene
22308       sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
22309 !        print *,"enecomp",sumene,sumene2
22310 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
22311 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
22312 #ifdef DEBUG
22313       write (2,*) "x",(x(k),k=1,9)
22314 !C
22315 !C This section to check the numerical derivatives of the energy of ith side
22316 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
22317 !C #define DEBUG in the code to turn it on.
22318 !C
22319       write (2,*) "sumene               =",sumene
22320       aincr=1.0d-7
22321       xxsave=xx
22322       xx=xx+aincr
22323       write (2,*) xx,yy,zz
22324       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22325       de_dxx_num=(sumenep-sumene)/aincr
22326       xx=xxsave
22327       write (2,*) "xx+ sumene from enesc=",sumenep,sumene
22328       yysave=yy
22329       yy=yy+aincr
22330       write (2,*) xx,yy,zz
22331       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22332       de_dyy_num=(sumenep-sumene)/aincr
22333       yy=yysave
22334       write (2,*) "yy+ sumene from enesc=",sumenep,sumene
22335       zzsave=zz
22336       zz=zz+aincr
22337       write (2,*) xx,yy,zz
22338       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22339       de_dzz_num=(sumenep-sumene)/aincr
22340       zz=zzsave
22341       write (2,*) "zz+ sumene from enesc=",sumenep,sumene
22342       costsave=cost2tab(i+1)
22343       sintsave=sint2tab(i+1)
22344       cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
22345       sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
22346       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22347       de_dt_num=(sumenep-sumene)/aincr
22348       write (2,*) " t+ sumene from enesc=",sumenep,sumene
22349       cost2tab(i+1)=costsave
22350       sint2tab(i+1)=sintsave
22351 !C End of diagnostics section.
22352 #endif
22353 !C
22354 !C Compute the gradient of esc
22355 !C
22356       de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
22357       de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
22358       de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
22359       de_dtt=0.0d0
22360 #ifdef DEBUG
22361       write (2,*) "x",(x(k),k=1,9)
22362       write (2,*) "xx",xx," yy",yy," zz",zz
22363       write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
22364         " de_zz   ",de_zz," de_tt   ",de_tt
22365       write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
22366         " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
22367 #endif
22368 !C
22369        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
22370        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
22371        cosfac2xx=cosfac2*xx
22372        sinfac2yy=sinfac2*yy
22373        do k = 1,3
22374        dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
22375          vbld_inv(i+1)
22376        dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
22377          vbld_inv(i)
22378        pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
22379        pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
22380 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
22381 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
22382 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
22383 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
22384        dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
22385        dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
22386        dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
22387        dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
22388        dZZ_Ci1(k)=0.0d0
22389        dZZ_Ci(k)=0.0d0
22390        do j=1,3
22391          dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
22392          dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
22393        enddo
22394
22395        dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
22396        dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
22397        dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
22398 !c
22399        dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
22400        dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
22401        enddo
22402
22403        do k=1,3
22404        dXX_Ctab(k,i)=dXX_Ci(k)
22405        dXX_C1tab(k,i)=dXX_Ci1(k)
22406        dYY_Ctab(k,i)=dYY_Ci(k)
22407        dYY_C1tab(k,i)=dYY_Ci1(k)
22408        dZZ_Ctab(k,i)=dZZ_Ci(k)
22409        dZZ_C1tab(k,i)=dZZ_Ci1(k)
22410        dXX_XYZtab(k,i)=dXX_XYZ(k)
22411        dYY_XYZtab(k,i)=dYY_XYZ(k)
22412        dZZ_XYZtab(k,i)=dZZ_XYZ(k)
22413        enddo
22414        do k = 1,3
22415 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
22416 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
22417 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
22418 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
22419 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
22420 !c     &    dt_dci(k)
22421 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
22422 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
22423        gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
22424        +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
22425        gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
22426        +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
22427        gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
22428        +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
22429 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
22430        enddo
22431 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
22432 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
22433
22434 !C to check gradient call subroutine check_grad
22435
22436     1 continue
22437       enddo
22438       return
22439       end subroutine esb
22440 !=-------------------------------------------------------
22441       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
22442 !      implicit none
22443       real(kind=8),dimension(9):: x(9)
22444        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
22445       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
22446       integer i
22447 !c      write (2,*) "enesc"
22448 !c      write (2,*) "x",(x(i),i=1,9)
22449 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
22450       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
22451       + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
22452       + x(9)*yy*zz
22453       enesc_nucl=sumene
22454       return
22455       end function enesc_nucl
22456 !-----------------------------------------------------------------------------
22457       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
22458 #ifdef MPI
22459       include 'mpif.h'
22460       integer,parameter :: max_cont=2000
22461       integer,parameter:: max_dim=2*(8*3+6)
22462       integer, parameter :: msglen1=max_cont*max_dim
22463       integer,parameter :: msglen2=2*msglen1
22464       integer source,CorrelType,CorrelID,Error
22465       real(kind=8) :: buffer(max_cont,max_dim)
22466       integer status(MPI_STATUS_SIZE)
22467       integer :: ierror,nbytes
22468 #endif
22469       real(kind=8),dimension(3):: gx(3),gx1(3)
22470       real(kind=8) :: time00
22471       logical lprn,ldone
22472       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
22473       real(kind=8) ecorr,ecorr3
22474       integer :: n_corr,n_corr1,mm,msglen
22475 !C Set lprn=.true. for debugging
22476       lprn=.false.
22477       n_corr=0
22478       n_corr1=0
22479 #ifdef MPI
22480       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
22481
22482       if (nfgtasks.le.1) goto 30
22483       if (lprn) then
22484       write (iout,'(a)') 'Contact function values:'
22485       do i=nnt,nct-1
22486         write (iout,'(2i3,50(1x,i2,f5.2))')  &
22487        i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
22488        j=1,num_cont_hb(i))
22489       enddo
22490       endif
22491 !C Caution! Following code assumes that electrostatic interactions concerning
22492 !C a given atom are split among at most two processors!
22493       CorrelType=477
22494       CorrelID=fg_rank+1
22495       ldone=.false.
22496       do i=1,max_cont
22497       do j=1,max_dim
22498         buffer(i,j)=0.0D0
22499       enddo
22500       enddo
22501       mm=mod(fg_rank,2)
22502 !c      write (*,*) 'MyRank',MyRank,' mm',mm
22503       if (mm) 20,20,10
22504    10 continue
22505 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
22506       if (fg_rank.gt.0) then
22507 !C Send correlation contributions to the preceding processor
22508       msglen=msglen1
22509       nn=num_cont_hb(iatel_s_nucl)
22510       call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
22511 !c        write (*,*) 'The BUFFER array:'
22512 !c        do i=1,nn
22513 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
22514 !c        enddo
22515       if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
22516         msglen=msglen2
22517         call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
22518 !C Clear the contacts of the atom passed to the neighboring processor
22519       nn=num_cont_hb(iatel_s_nucl+1)
22520 !c        do i=1,nn
22521 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
22522 !c        enddo
22523           num_cont_hb(iatel_s_nucl)=0
22524       endif
22525 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
22526 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
22527 !cd   & ' msglen=',msglen
22528 !c        write (*,*) 'Processor ',fg_rank,MyRank,
22529 !c     & ' is sending correlation contribution to processor',fg_rank-1,
22530 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
22531       time00=MPI_Wtime()
22532       call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
22533        CorrelType,FG_COMM,IERROR)
22534       time_sendrecv=time_sendrecv+MPI_Wtime()-time00
22535 !cd      write (iout,*) 'Processor ',fg_rank,
22536 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
22537 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
22538 !c        write (*,*) 'Processor ',fg_rank,
22539 !c     & ' has sent correlation contribution to processor',fg_rank-1,
22540 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
22541 !c        msglen=msglen1
22542       endif ! (fg_rank.gt.0)
22543       if (ldone) goto 30
22544       ldone=.true.
22545    20 continue
22546 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
22547       if (fg_rank.lt.nfgtasks-1) then
22548 !C Receive correlation contributions from the next processor
22549       msglen=msglen1
22550       if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
22551 !cd      write (iout,*) 'Processor',fg_rank,
22552 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
22553 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
22554 !c        write (*,*) 'Processor',fg_rank,
22555 !c     &' is receiving correlation contribution from processor',fg_rank+1,
22556 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
22557       time00=MPI_Wtime()
22558       nbytes=-1
22559       do while (nbytes.le.0)
22560         call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
22561         call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
22562       enddo
22563 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
22564       call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
22565        fg_rank+1,CorrelType,FG_COMM,status,IERROR)
22566       time_sendrecv=time_sendrecv+MPI_Wtime()-time00
22567 !c        write (*,*) 'Processor',fg_rank,
22568 !c     &' has received correlation contribution from processor',fg_rank+1,
22569 !c     & ' msglen=',msglen,' nbytes=',nbytes
22570 !c        write (*,*) 'The received BUFFER array:'
22571 !c        do i=1,max_cont
22572 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
22573 !c        enddo
22574       if (msglen.eq.msglen1) then
22575         call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
22576       else if (msglen.eq.msglen2)  then
22577         call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
22578         call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
22579       else
22580         write (iout,*) &
22581       'ERROR!!!! message length changed while processing correlations.'
22582         write (*,*) &
22583       'ERROR!!!! message length changed while processing correlations.'
22584         call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
22585       endif ! msglen.eq.msglen1
22586       endif ! fg_rank.lt.nfgtasks-1
22587       if (ldone) goto 30
22588       ldone=.true.
22589       goto 10
22590    30 continue
22591 #endif
22592       if (lprn) then
22593       write (iout,'(a)') 'Contact function values:'
22594       do i=nnt_molec(2),nct_molec(2)-1
22595         write (iout,'(2i3,50(1x,i2,f5.2))') &
22596        i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
22597        j=1,num_cont_hb(i))
22598       enddo
22599       endif
22600       ecorr=0.0D0
22601       ecorr3=0.0d0
22602 !C Remove the loop below after debugging !!!
22603 !      do i=nnt_molec(2),nct_molec(2)
22604 !        do j=1,3
22605 !          gradcorr_nucl(j,i)=0.0D0
22606 !          gradxorr_nucl(j,i)=0.0D0
22607 !          gradcorr3_nucl(j,i)=0.0D0
22608 !          gradxorr3_nucl(j,i)=0.0D0
22609 !        enddo
22610 !      enddo
22611 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
22612 !C Calculate the local-electrostatic correlation terms
22613       do i=iatsc_s_nucl,iatsc_e_nucl
22614       i1=i+1
22615       num_conti=num_cont_hb(i)
22616       num_conti1=num_cont_hb(i+1)
22617 !        print *,i,num_conti,num_conti1
22618       do jj=1,num_conti
22619         j=jcont_hb(jj,i)
22620         do kk=1,num_conti1
22621           j1=jcont_hb(kk,i1)
22622 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
22623 !c     &         ' jj=',jj,' kk=',kk
22624           if (j1.eq.j+1 .or. j1.eq.j-1) then
22625 !C
22626 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
22627 !C The system gains extra energy.
22628 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
22629 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22630 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
22631 !C
22632             ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22633             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
22634              'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22635             n_corr=n_corr+1
22636           else if (j1.eq.j) then
22637 !C
22638 !C Contacts I-J and I-(J+1) occur simultaneously.
22639 !C The system loses extra energy.
22640 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
22641 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22642 !C Need to implement full formulas 32 from Liwo et al., 1998.
22643 !C
22644 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22645 !c     &         ' jj=',jj,' kk=',kk
22646             ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
22647           endif
22648         enddo ! kk
22649         do kk=1,num_conti
22650           j1=jcont_hb(kk,i)
22651 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22652 !c     &         ' jj=',jj,' kk=',kk
22653           if (j1.eq.j+1) then
22654 !C Contacts I-J and (I+1)-J occur simultaneously.
22655 !C The system loses extra energy.
22656             ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
22657           endif ! j1==j+1
22658         enddo ! kk
22659       enddo ! jj
22660       enddo ! i
22661       return
22662       end subroutine multibody_hb_nucl
22663 !-----------------------------------------------------------
22664       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22665 !      implicit real*8 (a-h,o-z)
22666 !      include 'DIMENSIONS'
22667 !      include 'COMMON.IOUNITS'
22668 !      include 'COMMON.DERIV'
22669 !      include 'COMMON.INTERACT'
22670 !      include 'COMMON.CONTACTS'
22671       real(kind=8),dimension(3) :: gx,gx1
22672       logical :: lprn
22673 !el local variables
22674       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22675       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22676                ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22677                coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22678                rlocshield
22679
22680       lprn=.false.
22681       eij=facont_hb(jj,i)
22682       ekl=facont_hb(kk,k)
22683       ees0pij=ees0p(jj,i)
22684       ees0pkl=ees0p(kk,k)
22685       ees0mij=ees0m(jj,i)
22686       ees0mkl=ees0m(kk,k)
22687       ekont=eij*ekl
22688       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22689 !      print *,"ehbcorr_nucl",ekont,ees
22690 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22691 !C Following 4 lines for diagnostics.
22692 !cd    ees0pkl=0.0D0
22693 !cd    ees0pij=1.0D0
22694 !cd    ees0mkl=0.0D0
22695 !cd    ees0mij=1.0D0
22696 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22697 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22698 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22699 !C Calculate the multi-body contribution to energy.
22700 !      ecorr_nucl=ecorr_nucl+ekont*ees
22701 !C Calculate multi-body contributions to the gradient.
22702       coeffpees0pij=coeffp*ees0pij
22703       coeffmees0mij=coeffm*ees0mij
22704       coeffpees0pkl=coeffp*ees0pkl
22705       coeffmees0mkl=coeffm*ees0mkl
22706       do ll=1,3
22707       gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
22708        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22709        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22710       gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
22711       -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
22712       coeffmees0mkl*gacontm_hb2(ll,jj,i))
22713       gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
22714       -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
22715       coeffmees0mij*gacontm_hb1(ll,kk,k))
22716       gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
22717       -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22718       coeffmees0mij*gacontm_hb2(ll,kk,k))
22719       gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22720         ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22721         coeffmees0mkl*gacontm_hb3(ll,jj,i))
22722       gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
22723       gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
22724       gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22725         ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22726         coeffmees0mij*gacontm_hb3(ll,kk,k))
22727       gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
22728       gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
22729       gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
22730       gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
22731       gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
22732       gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
22733       enddo
22734       ehbcorr_nucl=ekont*ees
22735       return
22736       end function ehbcorr_nucl
22737 !-------------------------------------------------------------------------
22738
22739      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22740 !      implicit real*8 (a-h,o-z)
22741 !      include 'DIMENSIONS'
22742 !      include 'COMMON.IOUNITS'
22743 !      include 'COMMON.DERIV'
22744 !      include 'COMMON.INTERACT'
22745 !      include 'COMMON.CONTACTS'
22746       real(kind=8),dimension(3) :: gx,gx1
22747       logical :: lprn
22748 !el local variables
22749       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22750       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22751                ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22752                coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22753                rlocshield
22754
22755       lprn=.false.
22756       eij=facont_hb(jj,i)
22757       ekl=facont_hb(kk,k)
22758       ees0pij=ees0p(jj,i)
22759       ees0pkl=ees0p(kk,k)
22760       ees0mij=ees0m(jj,i)
22761       ees0mkl=ees0m(kk,k)
22762       ekont=eij*ekl
22763       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22764 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22765 !C Following 4 lines for diagnostics.
22766 !cd    ees0pkl=0.0D0
22767 !cd    ees0pij=1.0D0
22768 !cd    ees0mkl=0.0D0
22769 !cd    ees0mij=1.0D0
22770 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22771 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22772 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22773 !C Calculate the multi-body contribution to energy.
22774 !      ecorr=ecorr+ekont*ees
22775 !C Calculate multi-body contributions to the gradient.
22776       coeffpees0pij=coeffp*ees0pij
22777       coeffmees0mij=coeffm*ees0mij
22778       coeffpees0pkl=coeffp*ees0pkl
22779       coeffmees0mkl=coeffm*ees0mkl
22780       do ll=1,3
22781       gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
22782        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22783        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22784       gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
22785       -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
22786       coeffmees0mkl*gacontm_hb2(ll,jj,i))
22787       gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
22788       -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
22789       coeffmees0mij*gacontm_hb1(ll,kk,k))
22790       gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
22791       -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22792       coeffmees0mij*gacontm_hb2(ll,kk,k))
22793       gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22794         ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22795         coeffmees0mkl*gacontm_hb3(ll,jj,i))
22796       gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
22797       gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
22798       gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22799         ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22800         coeffmees0mij*gacontm_hb3(ll,kk,k))
22801       gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
22802       gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
22803       gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
22804       gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
22805       gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
22806       gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
22807       enddo
22808       ehbcorr3_nucl=ekont*ees
22809       return
22810       end function ehbcorr3_nucl
22811 #ifdef MPI
22812       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
22813       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22814       real(kind=8):: buffer(dimen1,dimen2)
22815       num_kont=num_cont_hb(atom)
22816       do i=1,num_kont
22817       do k=1,8
22818         do j=1,3
22819           buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
22820         enddo ! j
22821       enddo ! k
22822       buffer(i,indx+25)=facont_hb(i,atom)
22823       buffer(i,indx+26)=ees0p(i,atom)
22824       buffer(i,indx+27)=ees0m(i,atom)
22825       buffer(i,indx+28)=d_cont(i,atom)
22826       buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
22827       enddo ! i
22828       buffer(1,indx+30)=dfloat(num_kont)
22829       return
22830       end subroutine pack_buffer
22831 !c------------------------------------------------------------------------------
22832       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
22833       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22834       real(kind=8):: buffer(dimen1,dimen2)
22835 !      double precision zapas
22836 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
22837 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
22838 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
22839 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
22840       num_kont=buffer(1,indx+30)
22841       num_kont_old=num_cont_hb(atom)
22842       num_cont_hb(atom)=num_kont+num_kont_old
22843       do i=1,num_kont
22844       ii=i+num_kont_old
22845       do k=1,8
22846         do j=1,3
22847           zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
22848         enddo ! j
22849       enddo ! k
22850       facont_hb(ii,atom)=buffer(i,indx+25)
22851       ees0p(ii,atom)=buffer(i,indx+26)
22852       ees0m(ii,atom)=buffer(i,indx+27)
22853       d_cont(i,atom)=buffer(i,indx+28)
22854       jcont_hb(ii,atom)=buffer(i,indx+29)
22855       enddo ! i
22856       return
22857       end subroutine unpack_buffer
22858 !c------------------------------------------------------------------------------
22859 #endif
22860       subroutine ecatcat(ecationcation)
22861       integer :: i,j,itmp,xshift,yshift,zshift,subchap,k,itypi,itypj
22862       real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22863       r7,r4,ecationcation,k0,rcal,aa,bb,sslipi,ssgradlipi,sslipj,ssgradlipj
22864       real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22865       dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
22866       real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22867       gg,r
22868
22869       ecationcation=0.0d0
22870       if (nres_molec(5).eq.0) return
22871       rcat0=3.472
22872       epscalc=0.05
22873       r06 = rcat0**6
22874       r012 = r06**2
22875 !        k0 = 332.0*(2.0*2.0)/80.0
22876       itmp=0
22877
22878       do i=1,4
22879       itmp=itmp+nres_molec(i)
22880       enddo
22881 !        write(iout,*) "itmp",itmp
22882       do i=itmp+1,itmp+nres_molec(5)-1
22883
22884       xi=c(1,i)
22885       yi=c(2,i)
22886       zi=c(3,i)
22887 !        write (iout,*) i,"TUTUT",c(1,i)
22888         itypi=itype(i,5)
22889       call to_box(xi,yi,zi)
22890       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
22891         do j=i+1,itmp+nres_molec(5)
22892         itypj=itype(j,5)
22893 !          print *,i,j,itypi,itypj
22894         k0 = 332.0*(ichargecat(itypi)*ichargecat(itypj))/80.0
22895 !           print *,i,j,'catcat'
22896          xj=c(1,j)
22897          yj=c(2,j)
22898          zj=c(3,j)
22899       call to_box(xj,yj,zj)
22900 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
22901 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22902 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22903 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22904 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22905       xj=boxshift(xj-xi,boxxsize)
22906       yj=boxshift(yj-yi,boxysize)
22907       zj=boxshift(zj-zi,boxzsize)
22908        rcal =xj**2+yj**2+zj**2
22909       ract=sqrt(rcal)
22910 !        rcat0=3.472
22911 !        epscalc=0.05
22912 !        r06 = rcat0**6
22913 !        r012 = r06**2
22914 !        k0 = 332*(2*2)/80
22915       Evan1cat=epscalc*(r012/(rcal**6))
22916       Evan2cat=epscalc*2*(r06/(rcal**3))
22917       Eeleccat=k0/ract
22918       r7 = rcal**7
22919       r4 = rcal**4
22920       r(1)=xj
22921       r(2)=yj
22922       r(3)=zj
22923       do k=1,3
22924         dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
22925         dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
22926         dEeleccat(k)=-k0*r(k)/ract**3
22927       enddo
22928       do k=1,3
22929         gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
22930         gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
22931         gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
22932       enddo
22933       if (energy_dec) write (iout,*) i,j,Evan1cat,Evan2cat,Eeleccat,&
22934        r012,rcal**6,ichargecat(itypi)*ichargecat(itypj)
22935 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
22936       ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
22937        enddo
22938        enddo
22939        return
22940        end subroutine ecatcat
22941 !---------------------------------------------------------------------------
22942 ! new for K+
22943       subroutine ecats_prot_amber(evdw)
22944 !      subroutine ecat_prot2(ecation_prot)
22945       use calc_data
22946       use comm_momo
22947
22948       logical :: lprn
22949 !el local variables
22950       integer :: iint,itypi1,subchap,isel,itmp
22951       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
22952       real(kind=8) :: evdw,aa,bb
22953       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22954                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
22955                 sslipi,sslipj,faclip,alpha_sco
22956       integer :: ii
22957       real(kind=8) :: fracinbuf
22958       real (kind=8) :: escpho
22959       real (kind=8),dimension(4):: ener
22960       real(kind=8) :: b1,b2,egb
22961       real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
22962        Lambf,&
22963        Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
22964        ecations_prot_amber,dFdOM2,dFdL,dFdOM12,&
22965        federmaus,&
22966        d1i,d1j
22967 !       real(kind=8),dimension(3,2)::erhead_tail
22968 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
22969       real(kind=8) ::  facd4, adler, Fgb, facd3
22970       integer troll,jj,istate
22971       real (kind=8) :: dcosom1(3),dcosom2(3)
22972
22973       evdw=0.0D0
22974       if (nres_molec(5).eq.0) return
22975       eps_out=80.0d0
22976 !      sss_ele_cut=1.0d0
22977
22978       itmp=0
22979       do i=1,4
22980       itmp=itmp+nres_molec(i)
22981       enddo
22982 !        go to 17
22983 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
22984       do i=ibond_start,ibond_end
22985
22986 !        print *,"I am in EVDW",i
22987       itypi=iabs(itype(i,1))
22988
22989 !        if (i.ne.47) cycle
22990       if ((itypi.eq.ntyp1).or.(itypi.eq.10)) cycle
22991       itypi1=iabs(itype(i+1,1))
22992       xi=c(1,nres+i)
22993       yi=c(2,nres+i)
22994       zi=c(3,nres+i)
22995       call to_box(xi,yi,zi)
22996       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
22997       dxi=dc_norm(1,nres+i)
22998       dyi=dc_norm(2,nres+i)
22999       dzi=dc_norm(3,nres+i)
23000       dsci_inv=vbld_inv(i+nres)
23001        do j=itmp+1,itmp+nres_molec(5)
23002
23003 ! Calculate SC interaction energy.
23004           itypj=iabs(itype(j,5))
23005           if ((itypj.eq.ntyp1)) cycle
23006            CALL elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
23007
23008           dscj_inv=0.0
23009          xj=c(1,j)
23010          yj=c(2,j)
23011          zj=c(3,j)
23012
23013       call to_box(xj,yj,zj)
23014 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
23015 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23016 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23017 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23018 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23019       xj=boxshift(xj-xi,boxxsize)
23020       yj=boxshift(yj-yi,boxysize)
23021       zj=boxshift(zj-zi,boxzsize)
23022
23023 !          dxj = dc_norm( 1, nres+j )
23024 !          dyj = dc_norm( 2, nres+j )
23025 !          dzj = dc_norm( 3, nres+j )
23026
23027         itypi = itype(i,1)
23028         itypj = itype(j,5)
23029 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
23030 ! sampling performed with amber package
23031 !          alf1   = 0.0d0
23032 !          alf2   = 0.0d0
23033 !          alf12  = 0.0d0
23034 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
23035         chi1 = chi1cat(itypi,itypj)
23036         chis1 = chis1cat(itypi,itypj)
23037         chip1 = chipp1cat(itypi,itypj)
23038 !          chi1=0.0d0
23039 !          chis1=0.0d0
23040 !          chip1=0.0d0
23041         chi2=0.0
23042         chip2=0.0
23043         chis2=0.0
23044 !          chis2 = chis(itypj,itypi)
23045         chis12 = chis1 * chis2
23046         sig1 = sigmap1cat(itypi,itypj)
23047 !          sig2 = sigmap2(itypi,itypj)
23048 ! alpha factors from Fcav/Gcav
23049         b1cav = alphasurcat(1,itypi,itypj)
23050         b2cav = alphasurcat(2,itypi,itypj)
23051         b3cav = alphasurcat(3,itypi,itypj)
23052         b4cav = alphasurcat(4,itypi,itypj)
23053
23054 ! used to determine whether we want to do quadrupole calculations
23055        eps_in = epsintabcat(itypi,itypj)
23056        if (eps_in.eq.0.0) eps_in=1.0
23057
23058        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23059 !       Rtail = 0.0d0
23060
23061        DO k = 1, 3
23062       ctail(k,1)=c(k,i+nres)
23063       ctail(k,2)=c(k,j)
23064        END DO
23065 !c! tail distances will be themselves usefull elswhere
23066 !c1 (in Gcav, for example)
23067        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
23068        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
23069        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
23070        Rtail = dsqrt( &
23071         (Rtail_distance(1)*Rtail_distance(1)) &
23072       + (Rtail_distance(2)*Rtail_distance(2)) &
23073       + (Rtail_distance(3)*Rtail_distance(3)))
23074 ! tail location and distance calculations
23075 ! dhead1
23076        d1 = dheadcat(1, 1, itypi, itypj)
23077 !       d2 = dhead(2, 1, itypi, itypj)
23078        DO k = 1,3
23079 ! location of polar head is computed by taking hydrophobic centre
23080 ! and moving by a d1 * dc_norm vector
23081 ! see unres publications for very informative images
23082       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
23083       chead(k,2) = c(k, j)
23084 ! distance
23085 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23086 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23087       Rhead_distance(k) = chead(k,2) - chead(k,1)
23088        END DO
23089 ! pitagoras (root of sum of squares)
23090        Rhead = dsqrt( &
23091         (Rhead_distance(1)*Rhead_distance(1)) &
23092       + (Rhead_distance(2)*Rhead_distance(2)) &
23093       + (Rhead_distance(3)*Rhead_distance(3)))
23094 !-------------------------------------------------------------------
23095 ! zero everything that should be zero'ed
23096        evdwij = 0.0d0
23097        ECL = 0.0d0
23098        Elj = 0.0d0
23099        Equad = 0.0d0
23100        Epol = 0.0d0
23101        Fcav=0.0d0
23102        eheadtail = 0.0d0
23103        dGCLdOM1 = 0.0d0
23104        dGCLdOM2 = 0.0d0
23105        dGCLdOM12 = 0.0d0
23106        dPOLdOM1 = 0.0d0
23107        dPOLdOM2 = 0.0d0
23108         Fcav = 0.0d0
23109         dFdR = 0.0d0
23110         dCAVdOM1  = 0.0d0
23111         dCAVdOM2  = 0.0d0
23112         dCAVdOM12 = 0.0d0
23113         dscj_inv = vbld_inv(j+nres)
23114 !          print *,i,j,dscj_inv,dsci_inv
23115 ! rij holds 1/(distance of Calpha atoms)
23116         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23117         rij  = dsqrt(rrij)
23118         CALL sc_angular
23119 ! this should be in elgrad_init but om's are calculated by sc_angular
23120 ! which in turn is used by older potentials
23121 ! om = omega, sqom = om^2
23122         sqom1  = om1 * om1
23123         sqom2  = om2 * om2
23124         sqom12 = om12 * om12
23125
23126 ! now we calculate EGB - Gey-Berne
23127 ! It will be summed up in evdwij and saved in evdw
23128         sigsq     = 1.0D0  / sigsq
23129         sig       = sig0ij * dsqrt(sigsq)
23130 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23131         rij_shift = Rtail - sig + sig0ij
23132         IF (rij_shift.le.0.0D0) THEN
23133          evdw = 1.0D20
23134          RETURN
23135         END IF
23136         sigder = -sig * sigsq
23137         rij_shift = 1.0D0 / rij_shift
23138         fac       = rij_shift**expon
23139         c1        = fac  * fac * aa_aq_cat(itypi,itypj)
23140 !          print *,"ADAM",aa_aq(itypi,itypj)
23141
23142 !          c1        = 0.0d0
23143         c2        = fac  * bb_aq_cat(itypi,itypj)
23144 !          c2        = 0.0d0
23145         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23146         eps2der   = eps3rt * evdwij
23147         eps3der   = eps2rt * evdwij
23148 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23149         evdwij    = eps2rt * eps3rt * evdwij
23150 !#ifdef TSCSC
23151 !          IF (bb_aq(itypi,itypj).gt.0) THEN
23152 !           evdw_p = evdw_p + evdwij
23153 !          ELSE
23154 !           evdw_m = evdw_m + evdwij
23155 !          END IF
23156 !#else
23157         evdw = evdw  &
23158             + evdwij
23159 !#endif
23160         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23161         fac    = -expon * (c1 + evdwij) * rij_shift
23162         sigder = fac * sigder
23163 ! Calculate distance derivative
23164         gg(1) =  fac
23165         gg(2) =  fac
23166         gg(3) =  fac
23167
23168         fac = chis1 * sqom1 + chis2 * sqom2 &
23169         - 2.0d0 * chis12 * om1 * om2 * om12
23170         pom = 1.0d0 - chis1 * chis2 * sqom12
23171         Lambf = (1.0d0 - (fac / pom))
23172         Lambf = dsqrt(Lambf)
23173         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23174         Chif = Rtail * sparrow
23175         ChiLambf = Chif * Lambf
23176         eagle = dsqrt(ChiLambf)
23177         bat = ChiLambf ** 11.0d0
23178         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
23179         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
23180         botsq = bot * bot
23181         Fcav = top / bot
23182
23183        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
23184        dbot = 12.0d0 * b4cav * bat * Lambf
23185        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23186
23187         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
23188         dbot = 12.0d0 * b4cav * bat * Chif
23189         eagle = Lambf * pom
23190         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23191         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23192         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23193             * (chis2 * om2 * om12 - om1) / (eagle * pom)
23194
23195         dFdL = ((dtop * bot - top * dbot) / botsq)
23196         dCAVdOM1  = dFdL * ( dFdOM1 )
23197         dCAVdOM2  = dFdL * ( dFdOM2 )
23198         dCAVdOM12 = dFdL * ( dFdOM12 )
23199
23200        DO k= 1, 3
23201       ertail(k) = Rtail_distance(k)/Rtail
23202        END DO
23203        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
23204        erdxj = scalar( ertail(1), dC_norm(1,j) )
23205        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
23206        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j+nres)
23207        DO k = 1, 3
23208       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23209       gradpepcatx(k,i) = gradpepcatx(k,i) &
23210               - (( dFdR + gg(k) ) * pom)
23211       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23212 !        gvdwx(k,j) = gvdwx(k,j)   &
23213 !                  + (( dFdR + gg(k) ) * pom)
23214       gradpepcat(k,i) = gradpepcat(k,i)  &
23215               - (( dFdR + gg(k) ) * ertail(k))
23216       gradpepcat(k,j) = gradpepcat(k,j) &
23217               + (( dFdR + gg(k) ) * ertail(k))
23218       gg(k) = 0.0d0
23219        ENDDO
23220 !c! Compute head-head and head-tail energies for each state
23221         isel = iabs(Qi) + 1 ! ion is always charged so  iabs(Qj)
23222         IF (isel.eq.0) THEN
23223 !c! No charges - do nothing
23224          eheadtail = 0.0d0
23225
23226         ELSE IF (isel.eq.1) THEN
23227 !c! Nonpolar-charge interactions
23228         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23229           Qi=Qi*2
23230           Qij=Qij*2
23231          endif
23232         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
23233           Qj=Qj*2
23234           Qij=Qij*2
23235          endif
23236
23237          CALL enq_cat(epol)
23238          eheadtail = epol
23239 !           eheadtail = 0.0d0
23240
23241         ELSE IF (isel.eq.3) THEN
23242 !c! Dipole-charge interactions
23243         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23244           Qi=Qi*2
23245           Qij=Qij*2
23246          endif
23247         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
23248           Qj=Qj*2
23249           Qij=Qij*2
23250          endif
23251 !         write(iout,*) "KURWA0",d1
23252
23253          CALL edq_cat(ecl, elj, epol)
23254         eheadtail = ECL + elj + epol
23255 !           eheadtail = 0.0d0
23256
23257         ELSE IF ((isel.eq.2)) THEN
23258
23259 !c! Same charge-charge interaction ( +/+ or -/- )
23260         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23261           Qi=Qi*2
23262           Qij=Qij*2
23263          endif
23264         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
23265           Qj=Qj*2
23266           Qij=Qij*2
23267          endif
23268
23269          CALL eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
23270          eheadtail = ECL + Egb + Epol + Fisocav + Elj
23271 !           eheadtail = 0.0d0
23272
23273 !          ELSE IF ((isel.eq.2.and.  &
23274 !               iabs(Qi).eq.1).and. &
23275 !               nstate(itypi,itypj).ne.1) THEN
23276 !c! Different charge-charge interaction ( +/- or -/+ )
23277 !          if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23278 !            Qi=Qi*2
23279 !            Qij=Qij*2
23280 !           endif
23281 !          if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
23282 !            Qj=Qj*2
23283 !            Qij=Qij*2
23284 !           endif
23285 !
23286 !           CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
23287        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
23288       evdw = evdw  + Fcav + eheadtail
23289
23290        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
23291       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23292       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23293       Equad,evdwij+Fcav+eheadtail,evdw
23294 !       evdw = evdw  + Fcav  + eheadtail
23295
23296 !        iF (nstate(itypi,itypj).eq.1) THEN
23297       CALL sc_grad_cat
23298 !       END IF
23299 !c!-------------------------------------------------------------------
23300 !c! NAPISY KONCOWE
23301        END DO   ! j
23302        END DO     ! i
23303 !c      write (iout,*) "Number of loop steps in EGB:",ind
23304 !c      energy_dec=.false.
23305 !              print *,"EVDW KURW",evdw,nres
23306 !!!        return
23307    17   continue
23308       do i=ibond_start,ibond_end
23309
23310 !        print *,"I am in EVDW",i
23311       itypi=10 ! the peptide group parameters are for glicine
23312
23313 !        if (i.ne.47) cycle
23314       if ((itype(i,1).eq.ntyp1).or.itype(i+1,1).eq.ntyp1) cycle
23315       itypi1=iabs(itype(i+1,1))
23316       xi=(c(1,i)+c(1,i+1))/2.0
23317       yi=(c(2,i)+c(2,i+1))/2.0
23318       zi=(c(3,i)+c(3,i+1))/2.0
23319         call to_box(xi,yi,zi)
23320       dxi=dc_norm(1,i)
23321       dyi=dc_norm(2,i)
23322       dzi=dc_norm(3,i)
23323       dsci_inv=vbld_inv(i+1)/2.0
23324        do j=itmp+1,itmp+nres_molec(5)
23325
23326 ! Calculate SC interaction energy.
23327           itypj=iabs(itype(j,5))
23328           if ((itypj.eq.ntyp1)) cycle
23329            CALL elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
23330
23331           dscj_inv=0.0
23332          xj=c(1,j)
23333          yj=c(2,j)
23334          zj=c(3,j)
23335         call to_box(xj,yj,zj)
23336         dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23337
23338         dxj = 0.0d0! dc_norm( 1, nres+j )
23339         dyj = 0.0d0!dc_norm( 2, nres+j )
23340         dzj = 0.0d0! dc_norm( 3, nres+j )
23341
23342         itypi = 10
23343         itypj = itype(j,5)
23344 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
23345 ! sampling performed with amber package
23346 !          alf1   = 0.0d0
23347 !          alf2   = 0.0d0
23348 !          alf12  = 0.0d0
23349 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
23350         chi1 = chi1cat(itypi,itypj)
23351         chis1 = chis1cat(itypi,itypj)
23352         chip1 = chipp1cat(itypi,itypj)
23353 !          chi1=0.0d0
23354 !          chis1=0.0d0
23355 !          chip1=0.0d0
23356         chi2=0.0
23357         chip2=0.0
23358         chis2=0.0
23359 !          chis2 = chis(itypj,itypi)
23360         chis12 = chis1 * chis2
23361         sig1 = sigmap1cat(itypi,itypj)
23362 !          sig2 = sigmap2(itypi,itypj)
23363 ! alpha factors from Fcav/Gcav
23364         b1cav = alphasurcat(1,itypi,itypj)
23365         b2cav = alphasurcat(2,itypi,itypj)
23366         b3cav = alphasurcat(3,itypi,itypj)
23367         b4cav = alphasurcat(4,itypi,itypj)
23368
23369 ! used to determine whether we want to do quadrupole calculations
23370        eps_in = epsintabcat(itypi,itypj)
23371        if (eps_in.eq.0.0) eps_in=1.0
23372
23373        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23374 !       Rtail = 0.0d0
23375
23376        DO k = 1, 3
23377       ctail(k,1)=(c(k,i)+c(k,i+1))/2.0
23378       ctail(k,2)=c(k,j)
23379        END DO
23380 !c! tail distances will be themselves usefull elswhere
23381 !c1 (in Gcav, for example)
23382        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
23383        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
23384        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
23385        Rtail = dsqrt( &
23386         (Rtail_distance(1)*Rtail_distance(1)) &
23387       + (Rtail_distance(2)*Rtail_distance(2)) &
23388       + (Rtail_distance(3)*Rtail_distance(3)))
23389 ! tail location and distance calculations
23390 ! dhead1
23391        d1 = dheadcat(1, 1, itypi, itypj)
23392 !       print *,"d1",d1
23393 !       d1=0.0d0
23394 !       d2 = dhead(2, 1, itypi, itypj)
23395        DO k = 1,3
23396 ! location of polar head is computed by taking hydrophobic centre
23397 ! and moving by a d1 * dc_norm vector
23398 ! see unres publications for very informative images
23399       chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
23400       chead(k,2) = c(k, j)
23401 ! distance
23402 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23403 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23404       Rhead_distance(k) = chead(k,2) - chead(k,1)
23405        END DO
23406 ! pitagoras (root of sum of squares)
23407        Rhead = dsqrt( &
23408         (Rhead_distance(1)*Rhead_distance(1)) &
23409       + (Rhead_distance(2)*Rhead_distance(2)) &
23410       + (Rhead_distance(3)*Rhead_distance(3)))
23411 !-------------------------------------------------------------------
23412 ! zero everything that should be zero'ed
23413        evdwij = 0.0d0
23414        ECL = 0.0d0
23415        Elj = 0.0d0
23416        Equad = 0.0d0
23417        Epol = 0.0d0
23418        Fcav=0.0d0
23419        eheadtail = 0.0d0
23420        dGCLdOM1 = 0.0d0
23421        dGCLdOM2 = 0.0d0
23422        dGCLdOM12 = 0.0d0
23423        dPOLdOM1 = 0.0d0
23424        dPOLdOM2 = 0.0d0
23425         Fcav = 0.0d0
23426         dFdR = 0.0d0
23427         dCAVdOM1  = 0.0d0
23428         dCAVdOM2  = 0.0d0
23429         dCAVdOM12 = 0.0d0
23430         dscj_inv = vbld_inv(j+nres)
23431 !          print *,i,j,dscj_inv,dsci_inv
23432 ! rij holds 1/(distance of Calpha atoms)
23433         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23434         rij  = dsqrt(rrij)
23435         CALL sc_angular
23436 ! this should be in elgrad_init but om's are calculated by sc_angular
23437 ! which in turn is used by older potentials
23438 ! om = omega, sqom = om^2
23439         sqom1  = om1 * om1
23440         sqom2  = om2 * om2
23441         sqom12 = om12 * om12
23442
23443 ! now we calculate EGB - Gey-Berne
23444 ! It will be summed up in evdwij and saved in evdw
23445         sigsq     = 1.0D0  / sigsq
23446         sig       = sig0ij * dsqrt(sigsq)
23447 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23448         rij_shift = Rtail - sig + sig0ij
23449         IF (rij_shift.le.0.0D0) THEN
23450          evdw = 1.0D20
23451          RETURN
23452         END IF
23453         sigder = -sig * sigsq
23454         rij_shift = 1.0D0 / rij_shift
23455         fac       = rij_shift**expon
23456         c1        = fac  * fac * aa_aq_cat(itypi,itypj)
23457 !          print *,"ADAM",aa_aq(itypi,itypj)
23458
23459 !          c1        = 0.0d0
23460         c2        = fac  * bb_aq_cat(itypi,itypj)
23461 !          c2        = 0.0d0
23462         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23463         eps2der   = eps3rt * evdwij
23464         eps3der   = eps2rt * evdwij
23465 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23466         evdwij    = eps2rt * eps3rt * evdwij
23467 !#ifdef TSCSC
23468 !          IF (bb_aq(itypi,itypj).gt.0) THEN
23469 !           evdw_p = evdw_p + evdwij
23470 !          ELSE
23471 !           evdw_m = evdw_m + evdwij
23472 !          END IF
23473 !#else
23474         evdw = evdw  &
23475             + evdwij
23476 !#endif
23477         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23478         fac    = -expon * (c1 + evdwij) * rij_shift
23479         sigder = fac * sigder
23480 ! Calculate distance derivative
23481         gg(1) =  fac
23482         gg(2) =  fac
23483         gg(3) =  fac
23484
23485         fac = chis1 * sqom1 + chis2 * sqom2 &
23486         - 2.0d0 * chis12 * om1 * om2 * om12
23487
23488         pom = 1.0d0 - chis1 * chis2 * sqom12
23489 !          print *,"TUT2",fac,chis1,sqom1,pom
23490         Lambf = (1.0d0 - (fac / pom))
23491         Lambf = dsqrt(Lambf)
23492         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23493         Chif = Rtail * sparrow
23494         ChiLambf = Chif * Lambf
23495         eagle = dsqrt(ChiLambf)
23496         bat = ChiLambf ** 11.0d0
23497         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
23498         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
23499         botsq = bot * bot
23500         Fcav = top / bot
23501
23502        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
23503        dbot = 12.0d0 * b4cav * bat * Lambf
23504        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23505
23506         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
23507         dbot = 12.0d0 * b4cav * bat * Chif
23508         eagle = Lambf * pom
23509         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23510         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23511         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23512             * (chis2 * om2 * om12 - om1) / (eagle * pom)
23513
23514         dFdL = ((dtop * bot - top * dbot) / botsq)
23515         dCAVdOM1  = dFdL * ( dFdOM1 )
23516         dCAVdOM2  = dFdL * ( dFdOM2 )
23517         dCAVdOM12 = dFdL * ( dFdOM12 )
23518
23519        DO k= 1, 3
23520       ertail(k) = Rtail_distance(k)/Rtail
23521        END DO
23522        erdxi = scalar( ertail(1), dC_norm(1,i) )
23523        erdxj = scalar( ertail(1), dC_norm(1,j) )
23524        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i)
23525        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j+nres)
23526        DO k = 1, 3
23527       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i))
23528 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
23529 !                  - (( dFdR + gg(k) ) * pom)
23530       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23531 !        gvdwx(k,j) = gvdwx(k,j)   &
23532 !                  + (( dFdR + gg(k) ) * pom)
23533       gradpepcat(k,i) = gradpepcat(k,i)  &
23534               - (( dFdR + gg(k) ) * ertail(k))/2.0d0
23535       gradpepcat(k,i+1) = gradpepcat(k,i+1)  &
23536               - (( dFdR + gg(k) ) * ertail(k))/2.0d0
23537
23538       gradpepcat(k,j) = gradpepcat(k,j) &
23539               + (( dFdR + gg(k) ) * ertail(k))
23540       gg(k) = 0.0d0
23541        ENDDO
23542 !c! Compute head-head and head-tail energies for each state
23543         isel = 3
23544 !c! Dipole-charge interactions
23545         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23546           Qi=Qi*2
23547           Qij=Qij*2
23548          endif
23549         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
23550           Qj=Qj*2
23551           Qij=Qij*2
23552          endif
23553          CALL edq_cat_pep(ecl, elj, epol)
23554          eheadtail = ECL + elj + epol
23555 !          print *,"i,",i,eheadtail
23556 !           eheadtail = 0.0d0
23557
23558       evdw = evdw  + Fcav + eheadtail
23559
23560        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
23561       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23562       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23563       Equad,evdwij+Fcav+eheadtail,evdw
23564 !       evdw = evdw  + Fcav  + eheadtail
23565
23566 !        iF (nstate(itypi,itypj).eq.1) THEN
23567       CALL sc_grad_cat_pep
23568 !       END IF
23569 !c!-------------------------------------------------------------------
23570 !c! NAPISY KONCOWE
23571        END DO   ! j
23572        END DO     ! i
23573 !c      write (iout,*) "Number of loop steps in EGB:",ind
23574 !c      energy_dec=.false.
23575 !              print *,"EVDW KURW",evdw,nres
23576
23577
23578       return
23579       end subroutine ecats_prot_amber
23580
23581 !---------------------------------------------------------------------------
23582 ! old for Ca2+
23583        subroutine ecat_prot(ecation_prot)
23584 !      use calc_data
23585 !      use comm_momo
23586        integer i,j,k,subchap,itmp,inum
23587       real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
23588       r7,r4,ecationcation
23589       real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
23590       dist_init,dist_temp,ecation_prot,rcal,rocal,   &
23591       Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
23592       catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
23593       wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
23594       costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
23595       Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
23596       rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
23597       opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
23598       opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
23599       Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip,&
23600       ndiv,ndivi
23601       real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
23602       gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
23603       dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
23604       tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
23605       v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
23606       dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
23607       dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
23608       dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
23609       dEvan1Cat
23610       real(kind=8),dimension(6) :: vcatprm
23611       ecation_prot=0.0d0
23612 ! first lets calculate interaction with peptide groups
23613       if (nres_molec(5).eq.0) return
23614       itmp=0
23615       do i=1,4
23616       itmp=itmp+nres_molec(i)
23617       enddo
23618 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
23619       do i=ibond_start,ibond_end
23620 !         cycle
23621        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
23622       xi=0.5d0*(c(1,i)+c(1,i+1))
23623       yi=0.5d0*(c(2,i)+c(2,i+1))
23624       zi=0.5d0*(c(3,i)+c(3,i+1))
23625         call to_box(xi,yi,zi)
23626
23627        do j=itmp+1,itmp+nres_molec(5)
23628 !           print *,"WTF",itmp,j,i
23629 ! all parameters were for Ca2+ to approximate single charge divide by two
23630        ndiv=1.0
23631        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23632        wconst=78*ndiv
23633       wdip =1.092777950857032D2
23634       wdip=wdip/wconst
23635       wmodquad=-2.174122713004870D4
23636       wmodquad=wmodquad/wconst
23637       wquad1 = 3.901232068562804D1
23638       wquad1=wquad1/wconst
23639       wquad2 = 3
23640       wquad2=wquad2/wconst
23641       wvan1 = 0.1
23642       wvan2 = 6
23643 !        itmp=0
23644
23645          xj=c(1,j)
23646          yj=c(2,j)
23647          zj=c(3,j)
23648         call to_box(xj,yj,zj)
23649       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23650 !       enddo
23651 !       enddo
23652        rcpm = sqrt(xj**2+yj**2+zj**2)
23653        drcp_norm(1)=xj/rcpm
23654        drcp_norm(2)=yj/rcpm
23655        drcp_norm(3)=zj/rcpm
23656        dcmag=0.0
23657        do k=1,3
23658        dcmag=dcmag+dc(k,i)**2
23659        enddo
23660        dcmag=dsqrt(dcmag)
23661        do k=1,3
23662        myd_norm(k)=dc(k,i)/dcmag
23663        enddo
23664       costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
23665       drcp_norm(3)*myd_norm(3)
23666       rsecp = rcpm**2
23667       Ir = 1.0d0/rcpm
23668       Irsecp = 1.0d0/rsecp
23669       Irthrp = Irsecp/rcpm
23670       Irfourp = Irthrp/rcpm
23671       Irfiftp = Irfourp/rcpm
23672       Irsistp=Irfiftp/rcpm
23673       Irseven=Irsistp/rcpm
23674       Irtwelv=Irsistp*Irsistp
23675       Irthir=Irtwelv/rcpm
23676       sin2thet = (1-costhet*costhet)
23677       sinthet=sqrt(sin2thet)
23678       E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
23679            *sin2thet
23680       E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
23681            2*wvan2**6*Irsistp)
23682       ecation_prot = ecation_prot+E1+E2
23683 !        print *,"ecatprot",i,j,ecation_prot,rcpm
23684       dE1dr = -2*costhet*wdip*Irthrp-&
23685        (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
23686       dE2dr = 3*wquad1*wquad2*Irfourp-     &
23687         12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
23688       dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
23689       do k=1,3
23690         drdpep(k) = -drcp_norm(k)
23691         dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
23692         dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
23693         dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
23694         dEddci(k) = dEdcos*dcosddci(k)
23695       enddo
23696       do k=1,3
23697       gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
23698       gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
23699       gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
23700       enddo
23701        enddo ! j
23702        enddo ! i
23703 !------------------------------------------sidechains
23704 !        do i=1,nres_molec(1)
23705       do i=ibond_start,ibond_end
23706        if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
23707 !         cycle
23708 !        print *,i,ecation_prot
23709       xi=(c(1,i+nres))
23710       yi=(c(2,i+nres))
23711       zi=(c(3,i+nres))
23712                 call to_box(xi,yi,zi)
23713         do k=1,3
23714           cm1(k)=dc(k,i+nres)
23715         enddo
23716          cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
23717        do j=itmp+1,itmp+nres_molec(5)
23718        ndiv=1.0
23719        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23720
23721          xj=c(1,j)
23722          yj=c(2,j)
23723          zj=c(3,j)
23724         call to_box(xj,yj,zj)
23725       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23726 !       enddo
23727 !       enddo
23728 ! 15- Glu 16-Asp
23729        if((itype(i,1).eq.15.or.itype(i,1).eq.16).or.&
23730        ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.&
23731        (itype(i,1).eq.25))) then
23732           if(itype(i,1).eq.16) then
23733           inum=1
23734           else
23735           inum=2
23736           endif
23737           do k=1,6
23738           vcatprm(k)=catprm(k,inum)
23739           enddo
23740           dASGL=catprm(7,inum)
23741 !             do k=1,3
23742 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23743             vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23744             vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23745             vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23746
23747 !                valpha(k)=c(k,i)
23748 !                vcat(k)=c(k,j)
23749             if (subchap.eq.1) then
23750              vcat(1)=xj_temp
23751              vcat(2)=yj_temp
23752              vcat(3)=zj_temp
23753              else
23754             vcat(1)=xj_safe
23755             vcat(2)=yj_safe
23756             vcat(3)=zj_safe
23757              endif
23758             valpha(1)=xi-c(1,i+nres)+c(1,i)
23759             valpha(2)=yi-c(2,i+nres)+c(2,i)
23760             valpha(3)=zi-c(3,i+nres)+c(3,i)
23761
23762 !              enddo
23763       do k=1,3
23764         dx(k) = vcat(k)-vcm(k)
23765       enddo
23766       do k=1,3
23767         v1(k)=(vcm(k)-valpha(k))
23768         v2(k)=(vcat(k)-valpha(k))
23769       enddo
23770       v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23771       v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23772       v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23773
23774 !  The weights of the energy function calculated from
23775 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
23776         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23777           ndivi=0.5
23778         else
23779           ndivi=1.0
23780         endif
23781        ndiv=1.0
23782        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23783
23784       wh2o=78*ndivi*ndiv
23785       wc = vcatprm(1)
23786       wc=wc/wh2o
23787       wdip =vcatprm(2)
23788       wdip=wdip/wh2o
23789       wquad1 =vcatprm(3)
23790       wquad1=wquad1/wh2o
23791       wquad2 = vcatprm(4)
23792       wquad2=wquad2/wh2o
23793       wquad2p = 1.0d0-wquad2
23794       wvan1 = vcatprm(5)
23795       wvan2 =vcatprm(6)
23796       opt = dx(1)**2+dx(2)**2
23797       rsecp = opt+dx(3)**2
23798       rs = sqrt(rsecp)
23799       rthrp = rsecp*rs
23800       rfourp = rthrp*rs
23801       rsixp = rfourp*rsecp
23802       reight=rsixp*rsecp
23803       Ir = 1.0d0/rs
23804       Irsecp = 1.0d0/rsecp
23805       Irthrp = Irsecp/rs
23806       Irfourp = Irthrp/rs
23807       Irsixp = 1.0d0/rsixp
23808       Ireight=1.0d0/reight
23809       Irtw=Irsixp*Irsixp
23810       Irthir=Irtw/rs
23811       Irfourt=Irthir/rs
23812       opt1 = (4*rs*dx(3)*wdip)
23813       opt2 = 6*rsecp*wquad1*opt
23814       opt3 = wquad1*wquad2p*Irsixp
23815       opt4 = (wvan1*wvan2**12)
23816       opt5 = opt4*12*Irfourt
23817       opt6 = 2*wvan1*wvan2**6
23818       opt7 = 6*opt6*Ireight
23819       opt8 = wdip/v1m
23820       opt10 = wdip/v2m
23821       opt11 = (rsecp*v2m)**2
23822       opt12 = (rsecp*v1m)**2
23823       opt14 = (v1m*v2m*rsecp)**2
23824       opt15 = -wquad1/v2m**2
23825       opt16 = (rthrp*(v1m*v2m)**2)**2
23826       opt17 = (v1m**2*rthrp)**2
23827       opt18 = -wquad1/rthrp
23828       opt19 = (v1m**2*v2m**2)**2
23829       Ec = wc*Ir
23830       do k=1,3
23831         dEcCat(k) = -(dx(k)*wc)*Irthrp
23832         dEcCm(k)=(dx(k)*wc)*Irthrp
23833         dEcCalp(k)=0.0d0
23834       enddo
23835       Edip=opt8*(v1dpv2)/(rsecp*v2m)
23836       do k=1,3
23837         dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
23838                  *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23839         dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
23840                 *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23841         dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
23842                   *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
23843                   *v1dpv2)/opt14
23844       enddo
23845       Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23846       do k=1,3
23847         dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
23848                    (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
23849                    v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23850         dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
23851                   (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
23852                   v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23853         dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23854                   v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
23855                   v1dpv2**2)/opt19
23856       enddo
23857       Equad2=wquad1*wquad2p*Irthrp
23858       do k=1,3
23859         dEquad2Cat(k)=-3*dx(k)*rs*opt3
23860         dEquad2Cm(k)=3*dx(k)*rs*opt3
23861         dEquad2Calp(k)=0.0d0
23862       enddo
23863       Evan1=opt4*Irtw
23864       do k=1,3
23865         dEvan1Cat(k)=-dx(k)*opt5
23866         dEvan1Cm(k)=dx(k)*opt5
23867         dEvan1Calp(k)=0.0d0
23868       enddo
23869       Evan2=-opt6*Irsixp
23870       do k=1,3
23871         dEvan2Cat(k)=dx(k)*opt7
23872         dEvan2Cm(k)=-dx(k)*opt7
23873         dEvan2Calp(k)=0.0d0
23874       enddo
23875       ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
23876 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
23877
23878       do k=1,3
23879         dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
23880                    dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23881 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
23882         dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
23883                   dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23884         dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
23885                   +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23886       enddo
23887           dscmag = 0.0d0
23888           do k=1,3
23889             dscvec(k) = dc(k,i+nres)
23890             dscmag = dscmag+dscvec(k)*dscvec(k)
23891           enddo
23892           dscmag3 = dscmag
23893           dscmag = sqrt(dscmag)
23894           dscmag3 = dscmag3*dscmag
23895           constA = 1.0d0+dASGL/dscmag
23896           constB = 0.0d0
23897           do k=1,3
23898             constB = constB+dscvec(k)*dEtotalCm(k)
23899           enddo
23900           constB = constB*dASGL/dscmag3
23901           do k=1,3
23902             gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23903             gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23904              constA*dEtotalCm(k)-constB*dscvec(k)
23905 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
23906             gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23907             gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23908            enddo
23909       else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
23910          if(itype(i,1).eq.14) then
23911           inum=3
23912           else
23913           inum=4
23914           endif
23915           do k=1,6
23916           vcatprm(k)=catprm(k,inum)
23917           enddo
23918           dASGL=catprm(7,inum)
23919 !             do k=1,3
23920 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23921 !                valpha(k)=c(k,i)
23922 !                vcat(k)=c(k,j)
23923 !              enddo
23924             vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23925             vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23926             vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23927             if (subchap.eq.1) then
23928              vcat(1)=xj_temp
23929              vcat(2)=yj_temp
23930              vcat(3)=zj_temp
23931              else
23932             vcat(1)=xj_safe
23933             vcat(2)=yj_safe
23934             vcat(3)=zj_safe
23935             endif
23936             valpha(1)=xi-c(1,i+nres)+c(1,i)
23937             valpha(2)=yi-c(2,i+nres)+c(2,i)
23938             valpha(3)=zi-c(3,i+nres)+c(3,i)
23939
23940
23941       do k=1,3
23942         dx(k) = vcat(k)-vcm(k)
23943       enddo
23944       do k=1,3
23945         v1(k)=(vcm(k)-valpha(k))
23946         v2(k)=(vcat(k)-valpha(k))
23947       enddo
23948       v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23949       v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23950       v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23951 !  The weights of the energy function calculated from
23952 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
23953        ndiv=1.0
23954        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23955
23956       wh2o=78*ndiv
23957       wdip =vcatprm(2)
23958       wdip=wdip/wh2o
23959       wquad1 =vcatprm(3)
23960       wquad1=wquad1/wh2o
23961       wquad2 = vcatprm(4)
23962       wquad2=wquad2/wh2o
23963       wquad2p = 1-wquad2
23964       wvan1 = vcatprm(5)
23965       wvan2 =vcatprm(6)
23966       opt = dx(1)**2+dx(2)**2
23967       rsecp = opt+dx(3)**2
23968       rs = sqrt(rsecp)
23969       rthrp = rsecp*rs
23970       rfourp = rthrp*rs
23971       rsixp = rfourp*rsecp
23972       reight=rsixp*rsecp
23973       Ir = 1.0d0/rs
23974       Irsecp = 1/rsecp
23975       Irthrp = Irsecp/rs
23976       Irfourp = Irthrp/rs
23977       Irsixp = 1/rsixp
23978       Ireight=1/reight
23979       Irtw=Irsixp*Irsixp
23980       Irthir=Irtw/rs
23981       Irfourt=Irthir/rs
23982       opt1 = (4*rs*dx(3)*wdip)
23983       opt2 = 6*rsecp*wquad1*opt
23984       opt3 = wquad1*wquad2p*Irsixp
23985       opt4 = (wvan1*wvan2**12)
23986       opt5 = opt4*12*Irfourt
23987       opt6 = 2*wvan1*wvan2**6
23988       opt7 = 6*opt6*Ireight
23989       opt8 = wdip/v1m
23990       opt10 = wdip/v2m
23991       opt11 = (rsecp*v2m)**2
23992       opt12 = (rsecp*v1m)**2
23993       opt14 = (v1m*v2m*rsecp)**2
23994       opt15 = -wquad1/v2m**2
23995       opt16 = (rthrp*(v1m*v2m)**2)**2
23996       opt17 = (v1m**2*rthrp)**2
23997       opt18 = -wquad1/rthrp
23998       opt19 = (v1m**2*v2m**2)**2
23999       Edip=opt8*(v1dpv2)/(rsecp*v2m)
24000       do k=1,3
24001         dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
24002                  *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
24003        dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
24004                 *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
24005         dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
24006                   *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
24007                   *v1dpv2)/opt14
24008       enddo
24009       Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
24010       do k=1,3
24011         dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
24012                    (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
24013                    v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
24014         dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
24015                   (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
24016                    v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
24017         dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
24018                   v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
24019                   v1dpv2**2)/opt19
24020       enddo
24021       Equad2=wquad1*wquad2p*Irthrp
24022       do k=1,3
24023         dEquad2Cat(k)=-3*dx(k)*rs*opt3
24024         dEquad2Cm(k)=3*dx(k)*rs*opt3
24025         dEquad2Calp(k)=0.0d0
24026       enddo
24027       Evan1=opt4*Irtw
24028       do k=1,3
24029         dEvan1Cat(k)=-dx(k)*opt5
24030         dEvan1Cm(k)=dx(k)*opt5
24031         dEvan1Calp(k)=0.0d0
24032       enddo
24033       Evan2=-opt6*Irsixp
24034       do k=1,3
24035         dEvan2Cat(k)=dx(k)*opt7
24036         dEvan2Cm(k)=-dx(k)*opt7
24037         dEvan2Calp(k)=0.0d0
24038       enddo
24039        ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
24040       do k=1,3
24041         dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
24042                    dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
24043         dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
24044                   dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
24045         dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
24046                   +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
24047       enddo
24048           dscmag = 0.0d0
24049           do k=1,3
24050             dscvec(k) = c(k,i+nres)-c(k,i)
24051 ! TU SPRAWDZ???
24052 !              dscvec(1) = xj
24053 !              dscvec(2) = yj
24054 !              dscvec(3) = zj
24055
24056             dscmag = dscmag+dscvec(k)*dscvec(k)
24057           enddo
24058           dscmag3 = dscmag
24059           dscmag = sqrt(dscmag)
24060           dscmag3 = dscmag3*dscmag
24061           constA = 1+dASGL/dscmag
24062           constB = 0.0d0
24063           do k=1,3
24064             constB = constB+dscvec(k)*dEtotalCm(k)
24065           enddo
24066           constB = constB*dASGL/dscmag3
24067           do k=1,3
24068             gg(k) = dEtotalCm(k)+dEtotalCalp(k)
24069             gradpepcatx(k,i)=gradpepcatx(k,i)+ &
24070              constA*dEtotalCm(k)-constB*dscvec(k)
24071             gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
24072             gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
24073            enddo
24074          else
24075           rcal = 0.0d0
24076           do k=1,3
24077 !              r(k) = c(k,j)-c(k,i+nres)
24078             r(1) = xj
24079             r(2) = yj
24080             r(3) = zj
24081             rcal = rcal+r(k)*r(k)
24082           enddo
24083           ract=sqrt(rcal)
24084           rocal=1.5
24085           epscalc=0.2
24086           r0p=0.5*(rocal+sig0(itype(i,1)))
24087           r06 = r0p**6
24088           r012 = r06*r06
24089           Evan1=epscalc*(r012/rcal**6)
24090           Evan2=epscalc*2*(r06/rcal**3)
24091           r4 = rcal**4
24092           r7 = rcal**7
24093           do k=1,3
24094             dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
24095             dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
24096           enddo
24097           do k=1,3
24098             dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
24099           enddo
24100              ecation_prot = ecation_prot+ Evan1+Evan2
24101           do  k=1,3
24102              gradpepcatx(k,i)=gradpepcatx(k,i)+ &
24103              dEtotalCm(k)
24104             gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
24105             gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
24106            enddo
24107        endif ! 13-16 residues
24108        enddo !j
24109        enddo !i
24110        return
24111        end subroutine ecat_prot
24112
24113 !----------------------------------------------------------------------------
24114 !---------------------------------------------------------------------------
24115        subroutine ecat_nucl(ecation_nucl)
24116        integer i,j,k,subchap,itmp,inum,itypi,itypj
24117        real(kind=8) :: xi,yi,zi,xj,yj,zj
24118        real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
24119        dist_init,dist_temp,ecation_nucl,Evan1,Evan2,Ecav,Egb,wdip1,wdip2, &
24120        wvan1,wvan2,wgbsig,wgbeps,wgbchi,wgbchip,wcav1,wcav2,wcav3,wcav4, &
24121        wcavsig,wcavchi,v1m,v1dpdx,wh2o,wc,Edip,rcs2,invrcs6,invrcs8,invrcs12, &
24122        invrcs14,rcb,rcb2,invrcb,invrcb2,invrcb4,invrcb6,cosinus,cos2,dcosdcatconst, &
24123        dcosdcalpconst,dcosdcmconst,rcav,rcav11,rcav12,constcav1,constcav2, &
24124        constgb1,constgb2,constdvan1,constdvan2,sgb,sgb6,sgb7,sgb12,sgb13, &
24125        cavnum,cavdenom,invcavdenom2,dcavnumdcos,dcavnumdr,dcavdenomdcos, &
24126        dcavdenomdr,sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
24127        real(kind=8),dimension(3) ::gg,r,dEtotalCm,dEtotalCalp,dEvan1Cm,&
24128        dEvan2Cm,cm1,cm,vcat,vsug,v1,v2,dx,vcm,dEdipCm,dEdipCalp, &
24129        dEvan1Calp,dEvan2Cat,dEvan2Calp,dEtotalCat,dEdipCat,dEvan1Cat,dcosdcat, &
24130        dcosdcalp,dcosdcm,dEgbdCat,dEgbdCalp,dEgbdCm,dEcavdCat,dEcavdCalp, &
24131        dEcavdCm
24132        real(kind=8),dimension(14) :: vcatnuclprm
24133        ecation_nucl=0.0d0
24134        if (nres_molec(5).eq.0) return
24135        itmp=0
24136        do i=1,4
24137           itmp=itmp+nres_molec(i)
24138        enddo
24139        do i=iatsc_s_nucl,iatsc_e_nucl
24140           if ((itype(i,2).eq.ntyp1_molec(2))) cycle ! leave dummy atoms
24141           xi=(c(1,i+nres))
24142           yi=(c(2,i+nres))
24143           zi=(c(3,i+nres))
24144       call to_box(xi,yi,zi)
24145       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
24146           do k=1,3
24147              cm1(k)=dc(k,i+nres)
24148           enddo
24149           do j=itmp+1,itmp+nres_molec(5)
24150              xj=c(1,j)
24151              yj=c(2,j)
24152              zj=c(3,j)
24153       call to_box(xj,yj,zj)
24154 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
24155 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
24156 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
24157 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
24158 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
24159       xj=boxshift(xj-xi,boxxsize)
24160       yj=boxshift(yj-yi,boxysize)
24161       zj=boxshift(zj-zi,boxzsize)
24162
24163              dist_init=xj**2+yj**2+zj**2
24164
24165              itypi=itype(i,2)
24166              itypj=itype(j,5)
24167              do k=1,13
24168                 vcatnuclprm(k)=catnuclprm(k,itypi,itypj)
24169              enddo
24170              do k=1,3
24171                 vcm(k)=c(k,i+nres)
24172                 vsug(k)=c(k,i)
24173                 vcat(k)=c(k,j)
24174              enddo
24175              do k=1,3
24176                 dx(k) = vcat(k)-vcm(k)
24177              enddo
24178              do k=1,3
24179                 v1(k)=dc(k,i+nres)
24180                 v2(k)=(vcat(k)-vsug(k))
24181              enddo
24182              v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
24183              v1dpdx = v1(1)*dx(1)+v1(2)*dx(2)+v1(3)*dx(3)
24184 !  The weights of the energy function calculated from
24185 !The quantum mechanical Gaussian simulations of potassium and sodium with deoxynucleosides
24186              wh2o=78
24187              wdip1 = vcatnuclprm(1)
24188              wdip1 = wdip1/wh2o                     !w1
24189              wdip2 = vcatnuclprm(2)
24190              wdip2 = wdip2/wh2o                     !w2
24191              wvan1 = vcatnuclprm(3)
24192              wvan2 = vcatnuclprm(4)                 !pis1
24193              wgbsig = vcatnuclprm(5)                !sigma0
24194              wgbeps = vcatnuclprm(6)                !epsi0
24195              wgbchi = vcatnuclprm(7)                !chi1
24196              wgbchip = vcatnuclprm(8)               !chip1
24197              wcavsig = vcatnuclprm(9)               !sig
24198              wcav1 = vcatnuclprm(10)                !b1
24199              wcav2 = vcatnuclprm(11)                !b2
24200              wcav3 = vcatnuclprm(12)                !b3
24201              wcav4 = vcatnuclprm(13)                !b4
24202              wcavchi = vcatnuclprm(14)              !chis1
24203              rcs2 = v2(1)**2+v2(2)**2+v2(3)**2
24204              invrcs6 = 1/rcs2**3
24205              invrcs8 = invrcs6/rcs2
24206              invrcs12 = invrcs6**2
24207              invrcs14 = invrcs12/rcs2
24208              rcb2 = dx(1)**2+dx(2)**2+dx(3)**2
24209              rcb = sqrt(rcb2)
24210              invrcb = 1/rcb
24211              invrcb2 = invrcb**2
24212              invrcb4 = invrcb2**2
24213              invrcb6 = invrcb4*invrcb2
24214              cosinus = v1dpdx/(v1m*rcb)
24215              cos2 = cosinus**2
24216              dcosdcatconst = invrcb2/v1m
24217              dcosdcalpconst = invrcb/v1m**2
24218              dcosdcmconst = invrcb2/v1m**2
24219              do k=1,3
24220                 dcosdcat(k) = (v1(k)*rcb-dx(k)*v1m*cosinus)*dcosdcatconst
24221                 dcosdcalp(k) = (v1(k)*rcb*cosinus-dx(k)*v1m)*dcosdcalpconst
24222                 dcosdcm(k) = ((dx(k)-v1(k))*v1m*rcb+ &
24223                         cosinus*(dx(k)*v1m**2-v1(k)*rcb2))*dcosdcmconst
24224              enddo
24225              rcav = rcb/wcavsig
24226              rcav11 = rcav**11
24227              rcav12 = rcav11*rcav
24228              constcav1 = 1-wcavchi*cos2
24229              constcav2 = sqrt(constcav1)
24230              constgb1 = 1/sqrt(1-wgbchi*cos2)
24231              constgb2 = wgbeps*(1-wgbchip*cos2)**2
24232              constdvan1 = 12*wvan1*wvan2**12*invrcs14
24233              constdvan2 = 6*wvan1*wvan2**6*invrcs8
24234 !----------------------------------------------------------------------------
24235 !Gay-Berne term
24236 !---------------------------------------------------------------------------
24237              sgb = 1/(1-constgb1+(rcb/wgbsig))
24238              sgb6 = sgb**6
24239              sgb7 = sgb6*sgb
24240              sgb12 = sgb6**2
24241              sgb13 = sgb12*sgb
24242              Egb = constgb2*(sgb12-sgb6)
24243              do k=1,3
24244                 dEgbdCat(k) = -constgb2/wgbsig*(12*sgb13-6*sgb7)*invrcb*dx(k) &
24245                  +(constgb1**3*constgb2*wgbchi*cosinus*(12*sgb13-6*sgb7) &
24246      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcat(k)
24247                 dEgbdCm(k) = constgb2/wgbsig*(12*sgb13-6*sgb7)*invrcb*dx(k) &
24248                  +(constgb1**3*constgb2*wgbchi*cosinus*(12*sgb13-6*sgb7) &
24249      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcm(k)
24250                 dEgbdCalp(k) = (constgb1**3*constgb2*wgbchi*cosinus &
24251                                *(12*sgb13-6*sgb7) &
24252      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcalp(k)
24253              enddo
24254 !----------------------------------------------------------------------------
24255 !cavity term
24256 !---------------------------------------------------------------------------
24257              cavnum = sqrt(rcav*constcav2)+wcav2*rcav*constcav2-wcav3
24258              cavdenom = 1+wcav4*rcav12*constcav1**6
24259              Ecav = wcav1*cavnum/cavdenom
24260              invcavdenom2 = 1/cavdenom**2
24261              dcavnumdcos = -wcavchi*cosinus/constcav2 &
24262                     *(sqrt(rcav/constcav2)/2+wcav2*rcav)
24263              dcavnumdr = (0.5*sqrt(constcav2/rcav)+wcav2*constcav2)/wcavsig
24264              dcavdenomdcos = -12*wcav4*wcavchi*rcav12*constcav1**5*cosinus
24265              dcavdenomdr = 12*wcav4/wcavsig*rcav11*constcav1**6
24266              do k=1,3
24267                 dEcavdCat(k) = ((dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
24268      *dcosdcat(k)+(dcavnumdr*cavdenom-dcavdenomdr*cavnum)/rcb*dx(k))*wcav1*invcavdenom2
24269                 dEcavdCm(k) = ((dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
24270      *dcosdcm(k)-(dcavnumdr*cavdenom-dcavdenomdr*cavnum)/rcb*dx(k))*wcav1*invcavdenom2
24271                 dEcavdCalp(k) = (dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
24272                              *dcosdcalp(k)*wcav1*invcavdenom2
24273              enddo
24274 !----------------------------------------------------------------------------
24275 !van der Waals and dipole-charge interaction energy
24276 !---------------------------------------------------------------------------
24277              Evan1 = wvan1*wvan2**12*invrcs12
24278              do k=1,3
24279                 dEvan1Cat(k) = -v2(k)*constdvan1
24280                 dEvan1Cm(k) = 0.0d0
24281                 dEvan1Calp(k) = v2(k)*constdvan1
24282              enddo
24283              Evan2 = -wvan1*wvan2**6*invrcs6
24284              do k=1,3
24285                 dEvan2Cat(k) = v2(k)*constdvan2
24286                 dEvan2Cm(k) = 0.0d0
24287                 dEvan2Calp(k) = -v2(k)*constdvan2
24288              enddo
24289              Edip = wdip1*cosinus*invrcb2-wdip2*(1-cos2)*invrcb4
24290              do k=1,3
24291                 dEdipCat(k) = (-2*wdip1*cosinus*invrcb4 &
24292                                +4*wdip2*(1-cos2)*invrcb6)*dx(k) &
24293                    +dcosdcat(k)*(wdip1*invrcb2+2*wdip2*cosinus*invrcb4)
24294                 dEdipCm(k) = (2*wdip1*cosinus*invrcb4 &
24295                              -4*wdip2*(1-cos2)*invrcb6)*dx(k) &
24296                    +dcosdcm(k)*(wdip1*invrcb2+2*wdip2*cosinus*invrcb4)
24297                 dEdipCalp(k) = dcosdcalp(k)*(wdip1*invrcb2 &
24298                                   +2*wdip2*cosinus*invrcb4)
24299              enddo
24300              if (energy_dec) write (iout,'(2i5,4(a6,f7.3))') i,j, &
24301          ' E GB ',Egb,' ECav ',Ecav,' Evdw ',Evan1+Evan2,' Edip ',Edip
24302              ecation_nucl=ecation_nucl+Ecav+Egb+Edip+Evan1+Evan2
24303              do k=1,3
24304                 dEtotalCat(k) = dEcavdCat(k)+dEvan1Cat(k)+dEvan2Cat(k) &
24305                                              +dEgbdCat(k)+dEdipCat(k)
24306                 dEtotalCm(k) = dEcavdCm(k)+dEvan1Cm(k)+dEvan2Cm(k) &
24307                                            +dEgbdCm(k)+dEdipCm(k)
24308                 dEtotalCalp(k) = dEcavdCalp(k)+dEgbdCalp(k)+dEvan1Calp(k) &
24309                                              +dEdipCalp(k)+dEvan2Calp(k)
24310              enddo
24311              do k=1,3
24312                 gg(k) = dEtotalCm(k)+dEtotalCalp(k)
24313                 gradnuclcatx(k,i)=gradnuclcatx(k,i)+dEtotalCm(k)
24314                 gradnuclcat(k,i)=gradnuclcat(k,i)+gg(k)
24315                 gradnuclcat(k,j)=gradnuclcat(k,j)+dEtotalCat(k)
24316              enddo
24317           enddo !j
24318        enddo !i
24319        return
24320        end subroutine ecat_nucl
24321
24322 !-----------------------------------------------------------------------------
24323 !-----------------------------------------------------------------------------
24324       subroutine eprot_sc_base(escbase)
24325       use calc_data
24326 !      implicit real*8 (a-h,o-z)
24327 !      include 'DIMENSIONS'
24328 !      include 'COMMON.GEO'
24329 !      include 'COMMON.VAR'
24330 !      include 'COMMON.LOCAL'
24331 !      include 'COMMON.CHAIN'
24332 !      include 'COMMON.DERIV'
24333 !      include 'COMMON.NAMES'
24334 !      include 'COMMON.INTERACT'
24335 !      include 'COMMON.IOUNITS'
24336 !      include 'COMMON.CALC'
24337 !      include 'COMMON.CONTROL'
24338 !      include 'COMMON.SBRIDGE'
24339       logical :: lprn
24340 !el local variables
24341       integer :: iint,itypi,itypi1,itypj,subchap
24342       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24343       real(kind=8) :: evdw,sig0ij
24344       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24345                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24346                 sslipi,sslipj,faclip
24347       integer :: ii
24348       real(kind=8) :: fracinbuf
24349        real (kind=8) :: escbase
24350        real (kind=8),dimension(4):: ener
24351        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24352        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24353       sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
24354       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24355       dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
24356       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24357       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24358       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
24359        real(kind=8),dimension(3,2)::chead,erhead_tail
24360        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24361        integer troll
24362        eps_out=80.0d0
24363        escbase=0.0d0
24364 !       do i=1,nres_molec(1)
24365       do i=ibond_start,ibond_end
24366       if (itype(i,1).eq.ntyp1_molec(1)) cycle
24367       itypi  = itype(i,1)
24368       dxi    = dc_norm(1,nres+i)
24369       dyi    = dc_norm(2,nres+i)
24370       dzi    = dc_norm(3,nres+i)
24371       dsci_inv = vbld_inv(i+nres)
24372       xi=c(1,nres+i)
24373       yi=c(2,nres+i)
24374       zi=c(3,nres+i)
24375       call to_box(xi,yi,zi)
24376       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
24377        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
24378          itypj= itype(j,2)
24379          if (itype(j,2).eq.ntyp1_molec(2))cycle
24380          xj=c(1,j+nres)
24381          yj=c(2,j+nres)
24382          zj=c(3,j+nres)
24383       call to_box(xj,yj,zj)
24384 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
24385 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
24386 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
24387 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
24388 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
24389       xj=boxshift(xj-xi,boxxsize)
24390       yj=boxshift(yj-yi,boxysize)
24391       zj=boxshift(zj-zi,boxzsize)
24392
24393         dxj = dc_norm( 1, nres+j )
24394         dyj = dc_norm( 2, nres+j )
24395         dzj = dc_norm( 3, nres+j )
24396 !          print *,i,j,itypi,itypj
24397         d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
24398         d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
24399 !          d1i=0.0d0
24400 !          d1j=0.0d0
24401 !          BetaT = 1.0d0 / (298.0d0 * Rb)
24402 ! Gay-berne var's
24403         sig0ij = sigma_scbase( itypi,itypj )
24404         chi1   = chi_scbase( itypi, itypj,1 )
24405         chi2   = chi_scbase( itypi, itypj,2 )
24406 !          chi1=0.0d0
24407 !          chi2=0.0d0
24408         chi12  = chi1 * chi2
24409         chip1  = chipp_scbase( itypi, itypj,1 )
24410         chip2  = chipp_scbase( itypi, itypj,2 )
24411 !          chip1=0.0d0
24412 !          chip2=0.0d0
24413         chip12 = chip1 * chip2
24414 ! not used by momo potential, but needed by sc_angular which is shared
24415 ! by all energy_potential subroutines
24416         alf1   = 0.0d0
24417         alf2   = 0.0d0
24418         alf12  = 0.0d0
24419         a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
24420 !       a12sq = a12sq * a12sq
24421 ! charge of amino acid itypi is...
24422         chis1 = chis_scbase(itypi,itypj,1)
24423         chis2 = chis_scbase(itypi,itypj,2)
24424         chis12 = chis1 * chis2
24425         sig1 = sigmap1_scbase(itypi,itypj)
24426         sig2 = sigmap2_scbase(itypi,itypj)
24427 !       write (*,*) "sig1 = ", sig1
24428 !       write (*,*) "sig2 = ", sig2
24429 ! alpha factors from Fcav/Gcav
24430         b1 = alphasur_scbase(1,itypi,itypj)
24431 !          b1=0.0d0
24432         b2 = alphasur_scbase(2,itypi,itypj)
24433         b3 = alphasur_scbase(3,itypi,itypj)
24434         b4 = alphasur_scbase(4,itypi,itypj)
24435 ! used to determine whether we want to do quadrupole calculations
24436 ! used by Fgb
24437        eps_in = epsintab_scbase(itypi,itypj)
24438        if (eps_in.eq.0.0) eps_in=1.0
24439        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
24440 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
24441 !-------------------------------------------------------------------
24442 ! tail location and distance calculations
24443        DO k = 1,3
24444 ! location of polar head is computed by taking hydrophobic centre
24445 ! and moving by a d1 * dc_norm vector
24446 ! see unres publications for very informative images
24447       chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
24448       chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
24449 ! distance
24450 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24451 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24452       Rhead_distance(k) = chead(k,2) - chead(k,1)
24453        END DO
24454 ! pitagoras (root of sum of squares)
24455        Rhead = dsqrt( &
24456         (Rhead_distance(1)*Rhead_distance(1)) &
24457       + (Rhead_distance(2)*Rhead_distance(2)) &
24458       + (Rhead_distance(3)*Rhead_distance(3)))
24459 !-------------------------------------------------------------------
24460 ! zero everything that should be zero'ed
24461        evdwij = 0.0d0
24462        ECL = 0.0d0
24463        Elj = 0.0d0
24464        Equad = 0.0d0
24465        Epol = 0.0d0
24466        Fcav=0.0d0
24467        eheadtail = 0.0d0
24468        dGCLdOM1 = 0.0d0
24469        dGCLdOM2 = 0.0d0
24470        dGCLdOM12 = 0.0d0
24471        dPOLdOM1 = 0.0d0
24472        dPOLdOM2 = 0.0d0
24473         Fcav = 0.0d0
24474         dFdR = 0.0d0
24475         dCAVdOM1  = 0.0d0
24476         dCAVdOM2  = 0.0d0
24477         dCAVdOM12 = 0.0d0
24478         dscj_inv = vbld_inv(j+nres)
24479 !          print *,i,j,dscj_inv,dsci_inv
24480 ! rij holds 1/(distance of Calpha atoms)
24481         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24482         rij  = dsqrt(rrij)
24483 !----------------------------
24484         CALL sc_angular
24485 ! this should be in elgrad_init but om's are calculated by sc_angular
24486 ! which in turn is used by older potentials
24487 ! om = omega, sqom = om^2
24488         sqom1  = om1 * om1
24489         sqom2  = om2 * om2
24490         sqom12 = om12 * om12
24491
24492 ! now we calculate EGB - Gey-Berne
24493 ! It will be summed up in evdwij and saved in evdw
24494         sigsq     = 1.0D0  / sigsq
24495         sig       = sig0ij * dsqrt(sigsq)
24496 !          rij_shift = 1.0D0  / rij - sig + sig0ij
24497         rij_shift = 1.0/rij - sig + sig0ij
24498         IF (rij_shift.le.0.0D0) THEN
24499          evdw = 1.0D20
24500          RETURN
24501         END IF
24502         sigder = -sig * sigsq
24503         rij_shift = 1.0D0 / rij_shift
24504         fac       = rij_shift**expon
24505         c1        = fac  * fac * aa_scbase(itypi,itypj)
24506 !          c1        = 0.0d0
24507         c2        = fac  * bb_scbase(itypi,itypj)
24508 !          c2        = 0.0d0
24509         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24510         eps2der   = eps3rt * evdwij
24511         eps3der   = eps2rt * evdwij
24512 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24513         evdwij    = eps2rt * eps3rt * evdwij
24514         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24515         fac    = -expon * (c1 + evdwij) * rij_shift
24516         sigder = fac * sigder
24517 !          fac    = rij * fac
24518 ! Calculate distance derivative
24519         gg(1) =  fac
24520         gg(2) =  fac
24521         gg(3) =  fac
24522 !          if (b2.gt.0.0) then
24523         fac = chis1 * sqom1 + chis2 * sqom2 &
24524         - 2.0d0 * chis12 * om1 * om2 * om12
24525 ! we will use pom later in Gcav, so dont mess with it!
24526         pom = 1.0d0 - chis1 * chis2 * sqom12
24527         Lambf = (1.0d0 - (fac / pom))
24528         Lambf = dsqrt(Lambf)
24529         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24530 !       write (*,*) "sparrow = ", sparrow
24531         Chif = 1.0d0/rij * sparrow
24532         ChiLambf = Chif * Lambf
24533         eagle = dsqrt(ChiLambf)
24534         bat = ChiLambf ** 11.0d0
24535         top = b1 * ( eagle + b2 * ChiLambf - b3 )
24536         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24537         botsq = bot * bot
24538         Fcav = top / bot
24539 !          print *,i,j,Fcav
24540         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24541         dbot = 12.0d0 * b4 * bat * Lambf
24542         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24543 !       dFdR = 0.0d0
24544 !      write (*,*) "dFcav/dR = ", dFdR
24545         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24546         dbot = 12.0d0 * b4 * bat * Chif
24547         eagle = Lambf * pom
24548         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24549         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24550         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24551             * (chis2 * om2 * om12 - om1) / (eagle * pom)
24552
24553         dFdL = ((dtop * bot - top * dbot) / botsq)
24554 !       dFdL = 0.0d0
24555         dCAVdOM1  = dFdL * ( dFdOM1 )
24556         dCAVdOM2  = dFdL * ( dFdOM2 )
24557         dCAVdOM12 = dFdL * ( dFdOM12 )
24558
24559         ertail(1) = xj*rij
24560         ertail(2) = yj*rij
24561         ertail(3) = zj*rij
24562 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
24563 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
24564 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
24565 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
24566 !           print *,"EOMY",eom1,eom2,eom12
24567 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
24568 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
24569 ! here dtail=0.0
24570 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
24571 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24572        DO k = 1, 3
24573 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24574 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24575       pom = ertail(k)
24576 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24577       gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
24578               - (( dFdR + gg(k) ) * pom)
24579 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24580 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24581 !     &             - ( dFdR * pom )
24582       pom = ertail(k)
24583 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24584       gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
24585               + (( dFdR + gg(k) ) * pom)
24586 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24587 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24588 !c!     &             + ( dFdR * pom )
24589
24590       gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
24591               - (( dFdR + gg(k) ) * ertail(k))
24592 !c!     &             - ( dFdR * ertail(k))
24593
24594       gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
24595               + (( dFdR + gg(k) ) * ertail(k))
24596 !c!     &             + ( dFdR * ertail(k))
24597
24598       gg(k) = 0.0d0
24599 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24600 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24601       END DO
24602
24603 !          else
24604
24605 !          endif
24606 !Now dipole-dipole
24607        if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
24608        w1 = wdipdip_scbase(1,itypi,itypj)
24609        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
24610        w3 = wdipdip_scbase(2,itypi,itypj)
24611 !c!-------------------------------------------------------------------
24612 !c! ECL
24613        fac = (om12 - 3.0d0 * om1 * om2)
24614        c1 = (w1 / (Rhead**3.0d0)) * fac
24615        c2 = (w2 / Rhead ** 6.0d0)  &
24616        * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24617        c3= (w3/ Rhead ** 6.0d0)  &
24618        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24619        ECL = c1 - c2 + c3
24620 !c!       write (*,*) "w1 = ", w1
24621 !c!       write (*,*) "w2 = ", w2
24622 !c!       write (*,*) "om1 = ", om1
24623 !c!       write (*,*) "om2 = ", om2
24624 !c!       write (*,*) "om12 = ", om12
24625 !c!       write (*,*) "fac = ", fac
24626 !c!       write (*,*) "c1 = ", c1
24627 !c!       write (*,*) "c2 = ", c2
24628 !c!       write (*,*) "Ecl = ", Ecl
24629 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
24630 !c!       write (*,*) "c2_2 = ",
24631 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24632 !c!-------------------------------------------------------------------
24633 !c! dervative of ECL is GCL...
24634 !c! dECL/dr
24635        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
24636        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
24637        * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
24638        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
24639        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24640        dGCLdR = c1 - c2 + c3
24641 !c! dECL/dom1
24642        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
24643        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24644        * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
24645        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
24646        dGCLdOM1 = c1 - c2 + c3
24647 !c! dECL/dom2
24648        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
24649        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24650        * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
24651        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
24652        dGCLdOM2 = c1 - c2 + c3
24653 !c! dECL/dom12
24654        c1 = w1 / (Rhead ** 3.0d0)
24655        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
24656        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
24657        dGCLdOM12 = c1 - c2 + c3
24658        DO k= 1, 3
24659       erhead(k) = Rhead_distance(k)/Rhead
24660        END DO
24661        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24662        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24663        facd1 = d1i * vbld_inv(i+nres)
24664        facd2 = d1j * vbld_inv(j+nres)
24665        DO k = 1, 3
24666
24667       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24668       gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
24669               - dGCLdR * pom
24670       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24671       gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
24672               + dGCLdR * pom
24673
24674       gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
24675               - dGCLdR * erhead(k)
24676       gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
24677               + dGCLdR * erhead(k)
24678        END DO
24679        endif
24680 !now charge with dipole eg. ARG-dG
24681        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
24682       alphapol1 = alphapol_scbase(itypi,itypj)
24683        w1        = wqdip_scbase(1,itypi,itypj)
24684        w2        = wqdip_scbase(2,itypi,itypj)
24685 !       w1=0.0d0
24686 !       w2=0.0d0
24687 !       pis       = sig0head_scbase(itypi,itypj)
24688 !       eps_head   = epshead_scbase(itypi,itypj)
24689 !c!-------------------------------------------------------------------
24690 !c! R1 - distance between head of ith side chain and tail of jth sidechain
24691        R1 = 0.0d0
24692        DO k = 1, 3
24693 !c! Calculate head-to-tail distances tail is center of side-chain
24694       R1=R1+(c(k,j+nres)-chead(k,1))**2
24695        END DO
24696 !c! Pitagoras
24697        R1 = dsqrt(R1)
24698
24699 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24700 !c!     &        +dhead(1,1,itypi,itypj))**2))
24701 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24702 !c!     &        +dhead(2,1,itypi,itypj))**2))
24703
24704 !c!-------------------------------------------------------------------
24705 !c! ecl
24706        sparrow  = w1  *  om1
24707        hawk     = w2 *  (1.0d0 - sqom2)
24708        Ecl = sparrow / Rhead**2.0d0 &
24709          - hawk    / Rhead**4.0d0
24710 !c!-------------------------------------------------------------------
24711 !c! derivative of ecl is Gcl
24712 !c! dF/dr part
24713        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
24714             + 4.0d0 * hawk    / Rhead**5.0d0
24715 !c! dF/dom1
24716        dGCLdOM1 = (w1) / (Rhead**2.0d0)
24717 !c! dF/dom2
24718        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
24719 !c--------------------------------------------------------------------
24720 !c Polarization energy
24721 !c Epol
24722        MomoFac1 = (1.0d0 - chi1 * sqom2)
24723        RR1  = R1 * R1 / MomoFac1
24724        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24725        fgb1 = sqrt( RR1 + a12sq * ee1)
24726 !       eps_inout_fac=0.0d0
24727        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
24728 ! derivative of Epol is Gpol...
24729        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
24730             / (fgb1 ** 5.0d0)
24731        dFGBdR1 = ( (R1 / MomoFac1) &
24732            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
24733            / ( 2.0d0 * fgb1 )
24734        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
24735              * (2.0d0 - 0.5d0 * ee1) ) &
24736              / (2.0d0 * fgb1)
24737        dPOLdR1 = dPOLdFGB1 * dFGBdR1
24738 !       dPOLdR1 = 0.0d0
24739        dPOLdOM1 = 0.0d0
24740        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
24741        DO k = 1, 3
24742       erhead(k) = Rhead_distance(k)/Rhead
24743       erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
24744        END DO
24745
24746        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24747        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24748        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
24749 !       bat=0.0d0
24750        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
24751        facd1 = d1i * vbld_inv(i+nres)
24752        facd2 = d1j * vbld_inv(j+nres)
24753 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24754
24755        DO k = 1, 3
24756       hawk = (erhead_tail(k,1) + &
24757       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
24758 !        facd1=0.0d0
24759 !        facd2=0.0d0
24760       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24761       gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
24762                - dGCLdR * pom &
24763                - dPOLdR1 *  (erhead_tail(k,1))
24764 !     &             - dGLJdR * pom
24765
24766       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24767       gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
24768                + dGCLdR * pom  &
24769                + dPOLdR1 * (erhead_tail(k,1))
24770 !     &             + dGLJdR * pom
24771
24772
24773       gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
24774               - dGCLdR * erhead(k) &
24775               - dPOLdR1 * erhead_tail(k,1)
24776 !     &             - dGLJdR * erhead(k)
24777
24778       gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
24779               + dGCLdR * erhead(k)  &
24780               + dPOLdR1 * erhead_tail(k,1)
24781 !     &             + dGLJdR * erhead(k)
24782
24783        END DO
24784        endif
24785 !       print *,i,j,evdwij,epol,Fcav,ECL
24786        escbase=escbase+evdwij+epol+Fcav+ECL
24787        call sc_grad_scbase
24788        enddo
24789       enddo
24790
24791       return
24792       end subroutine eprot_sc_base
24793       SUBROUTINE sc_grad_scbase
24794       use calc_data
24795
24796        real (kind=8) :: dcosom1(3),dcosom2(3)
24797        eom1  =    &
24798             eps2der * eps2rt_om1   &
24799           - 2.0D0 * alf1 * eps3der &
24800           + sigder * sigsq_om1     &
24801           + dCAVdOM1               &
24802           + dGCLdOM1               &
24803           + dPOLdOM1
24804
24805        eom2  =  &
24806             eps2der * eps2rt_om2   &
24807           + 2.0D0 * alf2 * eps3der &
24808           + sigder * sigsq_om2     &
24809           + dCAVdOM2               &
24810           + dGCLdOM2               &
24811           + dPOLdOM2
24812
24813        eom12 =    &
24814             evdwij  * eps1_om12     &
24815           + eps2der * eps2rt_om12   &
24816           - 2.0D0 * alf12 * eps3der &
24817           + sigder *sigsq_om12      &
24818           + dCAVdOM12               &
24819           + dGCLdOM12
24820
24821 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24822 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24823 !               gg(1),gg(2),"rozne"
24824        DO k = 1, 3
24825       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
24826       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24827       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24828       gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
24829              + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24830              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24831       gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
24832              + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24833              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24834       gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
24835       gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
24836        END DO
24837        RETURN
24838       END SUBROUTINE sc_grad_scbase
24839
24840
24841       subroutine epep_sc_base(epepbase)
24842       use calc_data
24843       logical :: lprn
24844 !el local variables
24845       integer :: iint,itypi,itypi1,itypj,subchap
24846       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24847       real(kind=8) :: evdw,sig0ij
24848       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24849                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24850                 sslipi,sslipj,faclip
24851       integer :: ii
24852       real(kind=8) :: fracinbuf
24853        real (kind=8) :: epepbase
24854        real (kind=8),dimension(4):: ener
24855        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24856        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24857       sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
24858       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24859       dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
24860       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24861       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24862       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
24863        real(kind=8),dimension(3,2)::chead,erhead_tail
24864        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24865        integer troll
24866        eps_out=80.0d0
24867        epepbase=0.0d0
24868 !       do i=1,nres_molec(1)-1
24869       do i=ibond_start,ibond_end
24870       if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
24871 !C        itypi  = itype(i,1)
24872       dxi    = dc_norm(1,i)
24873       dyi    = dc_norm(2,i)
24874       dzi    = dc_norm(3,i)
24875 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
24876       dsci_inv = vbld_inv(i+1)/2.0
24877       xi=(c(1,i)+c(1,i+1))/2.0
24878       yi=(c(2,i)+c(2,i+1))/2.0
24879       zi=(c(3,i)+c(3,i+1))/2.0
24880         call to_box(xi,yi,zi)
24881        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
24882          itypj= itype(j,2)
24883          if (itype(j,2).eq.ntyp1_molec(2))cycle
24884          xj=c(1,j+nres)
24885          yj=c(2,j+nres)
24886          zj=c(3,j+nres)
24887                 call to_box(xj,yj,zj)
24888       xj=boxshift(xj-xi,boxxsize)
24889       yj=boxshift(yj-yi,boxysize)
24890       zj=boxshift(zj-zi,boxzsize)
24891         dist_init=xj**2+yj**2+zj**2
24892         dxj = dc_norm( 1, nres+j )
24893         dyj = dc_norm( 2, nres+j )
24894         dzj = dc_norm( 3, nres+j )
24895 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
24896 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
24897
24898 ! Gay-berne var's
24899         sig0ij = sigma_pepbase(itypj )
24900         chi1   = chi_pepbase(itypj,1 )
24901         chi2   = chi_pepbase(itypj,2 )
24902 !          chi1=0.0d0
24903 !          chi2=0.0d0
24904         chi12  = chi1 * chi2
24905         chip1  = chipp_pepbase(itypj,1 )
24906         chip2  = chipp_pepbase(itypj,2 )
24907 !          chip1=0.0d0
24908 !          chip2=0.0d0
24909         chip12 = chip1 * chip2
24910         chis1 = chis_pepbase(itypj,1)
24911         chis2 = chis_pepbase(itypj,2)
24912         chis12 = chis1 * chis2
24913         sig1 = sigmap1_pepbase(itypj)
24914         sig2 = sigmap2_pepbase(itypj)
24915 !       write (*,*) "sig1 = ", sig1
24916 !       write (*,*) "sig2 = ", sig2
24917        DO k = 1,3
24918 ! location of polar head is computed by taking hydrophobic centre
24919 ! and moving by a d1 * dc_norm vector
24920 ! see unres publications for very informative images
24921       chead(k,1) = (c(k,i)+c(k,i+1))/2.0
24922 ! + d1i * dc_norm(k, i+nres)
24923       chead(k,2) = c(k, j+nres)
24924 ! + d1j * dc_norm(k, j+nres)
24925 ! distance
24926 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24927 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24928       Rhead_distance(k) = chead(k,2) - chead(k,1)
24929 !        print *,gvdwc_pepbase(k,i)
24930
24931        END DO
24932        Rhead = dsqrt( &
24933         (Rhead_distance(1)*Rhead_distance(1)) &
24934       + (Rhead_distance(2)*Rhead_distance(2)) &
24935       + (Rhead_distance(3)*Rhead_distance(3)))
24936
24937 ! alpha factors from Fcav/Gcav
24938         b1 = alphasur_pepbase(1,itypj)
24939 !          b1=0.0d0
24940         b2 = alphasur_pepbase(2,itypj)
24941         b3 = alphasur_pepbase(3,itypj)
24942         b4 = alphasur_pepbase(4,itypj)
24943         alf1   = 0.0d0
24944         alf2   = 0.0d0
24945         alf12  = 0.0d0
24946         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24947 !          print *,i,j,rrij
24948         rij  = dsqrt(rrij)
24949 !----------------------------
24950        evdwij = 0.0d0
24951        ECL = 0.0d0
24952        Elj = 0.0d0
24953        Equad = 0.0d0
24954        Epol = 0.0d0
24955        Fcav=0.0d0
24956        eheadtail = 0.0d0
24957        dGCLdOM1 = 0.0d0
24958        dGCLdOM2 = 0.0d0
24959        dGCLdOM12 = 0.0d0
24960        dPOLdOM1 = 0.0d0
24961        dPOLdOM2 = 0.0d0
24962         Fcav = 0.0d0
24963         dFdR = 0.0d0
24964         dCAVdOM1  = 0.0d0
24965         dCAVdOM2  = 0.0d0
24966         dCAVdOM12 = 0.0d0
24967         dscj_inv = vbld_inv(j+nres)
24968         CALL sc_angular
24969 ! this should be in elgrad_init but om's are calculated by sc_angular
24970 ! which in turn is used by older potentials
24971 ! om = omega, sqom = om^2
24972         sqom1  = om1 * om1
24973         sqom2  = om2 * om2
24974         sqom12 = om12 * om12
24975
24976 ! now we calculate EGB - Gey-Berne
24977 ! It will be summed up in evdwij and saved in evdw
24978         sigsq     = 1.0D0  / sigsq
24979         sig       = sig0ij * dsqrt(sigsq)
24980         rij_shift = 1.0/rij - sig + sig0ij
24981         IF (rij_shift.le.0.0D0) THEN
24982          evdw = 1.0D20
24983          RETURN
24984         END IF
24985         sigder = -sig * sigsq
24986         rij_shift = 1.0D0 / rij_shift
24987         fac       = rij_shift**expon
24988         c1        = fac  * fac * aa_pepbase(itypj)
24989 !          c1        = 0.0d0
24990         c2        = fac  * bb_pepbase(itypj)
24991 !          c2        = 0.0d0
24992         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24993         eps2der   = eps3rt * evdwij
24994         eps3der   = eps2rt * evdwij
24995 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24996         evdwij    = eps2rt * eps3rt * evdwij
24997         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24998         fac    = -expon * (c1 + evdwij) * rij_shift
24999         sigder = fac * sigder
25000 !          fac    = rij * fac
25001 ! Calculate distance derivative
25002         gg(1) =  fac
25003         gg(2) =  fac
25004         gg(3) =  fac
25005         fac = chis1 * sqom1 + chis2 * sqom2 &
25006         - 2.0d0 * chis12 * om1 * om2 * om12
25007 ! we will use pom later in Gcav, so dont mess with it!
25008         pom = 1.0d0 - chis1 * chis2 * sqom12
25009         Lambf = (1.0d0 - (fac / pom))
25010         Lambf = dsqrt(Lambf)
25011         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
25012 !       write (*,*) "sparrow = ", sparrow
25013         Chif = 1.0d0/rij * sparrow
25014         ChiLambf = Chif * Lambf
25015         eagle = dsqrt(ChiLambf)
25016         bat = ChiLambf ** 11.0d0
25017         top = b1 * ( eagle + b2 * ChiLambf - b3 )
25018         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
25019         botsq = bot * bot
25020         Fcav = top / bot
25021 !          print *,i,j,Fcav
25022         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
25023         dbot = 12.0d0 * b4 * bat * Lambf
25024         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25025 !       dFdR = 0.0d0
25026 !      write (*,*) "dFcav/dR = ", dFdR
25027         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
25028         dbot = 12.0d0 * b4 * bat * Chif
25029         eagle = Lambf * pom
25030         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25031         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25032         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25033             * (chis2 * om2 * om12 - om1) / (eagle * pom)
25034
25035         dFdL = ((dtop * bot - top * dbot) / botsq)
25036 !       dFdL = 0.0d0
25037         dCAVdOM1  = dFdL * ( dFdOM1 )
25038         dCAVdOM2  = dFdL * ( dFdOM2 )
25039         dCAVdOM12 = dFdL * ( dFdOM12 )
25040
25041         ertail(1) = xj*rij
25042         ertail(2) = yj*rij
25043         ertail(3) = zj*rij
25044        DO k = 1, 3
25045 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25046 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25047       pom = ertail(k)
25048 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25049       gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
25050               - (( dFdR + gg(k) ) * pom)/2.0
25051 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
25052 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
25053 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25054 !     &             - ( dFdR * pom )
25055       pom = ertail(k)
25056 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25057       gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
25058               + (( dFdR + gg(k) ) * pom)
25059 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25060 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25061 !c!     &             + ( dFdR * pom )
25062
25063       gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
25064               - (( dFdR + gg(k) ) * ertail(k))/2.0
25065 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
25066
25067 !c!     &             - ( dFdR * ertail(k))
25068
25069       gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
25070               + (( dFdR + gg(k) ) * ertail(k))
25071 !c!     &             + ( dFdR * ertail(k))
25072
25073       gg(k) = 0.0d0
25074 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25075 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25076       END DO
25077
25078
25079        w1 = wdipdip_pepbase(1,itypj)
25080        w2 = -wdipdip_pepbase(3,itypj)/2.0
25081        w3 = wdipdip_pepbase(2,itypj)
25082 !       w1=0.0d0
25083 !       w2=0.0d0
25084 !c!-------------------------------------------------------------------
25085 !c! ECL
25086 !       w3=0.0d0
25087        fac = (om12 - 3.0d0 * om1 * om2)
25088        c1 = (w1 / (Rhead**3.0d0)) * fac
25089        c2 = (w2 / Rhead ** 6.0d0)  &
25090        * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
25091        c3= (w3/ Rhead ** 6.0d0)  &
25092        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
25093
25094        ECL = c1 - c2 + c3
25095
25096        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
25097        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
25098        * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
25099        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
25100        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
25101
25102        dGCLdR = c1 - c2 + c3
25103 !c! dECL/dom1
25104        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
25105        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
25106        * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
25107        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
25108        dGCLdOM1 = c1 - c2 + c3
25109 !c! dECL/dom2
25110        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
25111        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
25112        * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
25113        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
25114
25115        dGCLdOM2 = c1 - c2 + c3
25116 !c! dECL/dom12
25117        c1 = w1 / (Rhead ** 3.0d0)
25118        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
25119        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
25120        dGCLdOM12 = c1 - c2 + c3
25121        DO k= 1, 3
25122       erhead(k) = Rhead_distance(k)/Rhead
25123        END DO
25124        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25125        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25126 !       facd1 = d1 * vbld_inv(i+nres)
25127 !       facd2 = d2 * vbld_inv(j+nres)
25128        DO k = 1, 3
25129
25130 !        pom = erhead(k)
25131 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25132 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
25133 !                  - dGCLdR * pom
25134       pom = erhead(k)
25135 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25136       gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
25137               + dGCLdR * pom
25138
25139       gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
25140               - dGCLdR * erhead(k)/2.0d0
25141 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
25142       gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
25143               - dGCLdR * erhead(k)/2.0d0
25144 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
25145       gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
25146               + dGCLdR * erhead(k)
25147        END DO
25148 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
25149        epepbase=epepbase+evdwij+Fcav+ECL
25150        call sc_grad_pepbase
25151        enddo
25152        enddo
25153       END SUBROUTINE epep_sc_base
25154       SUBROUTINE sc_grad_pepbase
25155       use calc_data
25156
25157        real (kind=8) :: dcosom1(3),dcosom2(3)
25158        eom1  =    &
25159             eps2der * eps2rt_om1   &
25160           - 2.0D0 * alf1 * eps3der &
25161           + sigder * sigsq_om1     &
25162           + dCAVdOM1               &
25163           + dGCLdOM1               &
25164           + dPOLdOM1
25165
25166        eom2  =  &
25167             eps2der * eps2rt_om2   &
25168           + 2.0D0 * alf2 * eps3der &
25169           + sigder * sigsq_om2     &
25170           + dCAVdOM2               &
25171           + dGCLdOM2               &
25172           + dPOLdOM2
25173
25174        eom12 =    &
25175             evdwij  * eps1_om12     &
25176           + eps2der * eps2rt_om12   &
25177           - 2.0D0 * alf12 * eps3der &
25178           + sigder *sigsq_om12      &
25179           + dCAVdOM12               &
25180           + dGCLdOM12
25181 !        om12=0.0
25182 !        eom12=0.0
25183 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
25184 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
25185 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
25186 !                 *dsci_inv*2.0
25187 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
25188 !               gg(1),gg(2),"rozne"
25189        DO k = 1, 3
25190       dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
25191       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
25192       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25193       gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
25194              + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
25195              *dsci_inv*2.0 &
25196              - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25197       gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
25198              - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
25199              *dsci_inv*2.0 &
25200              + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25201 !         print *,eom12,eom2,om12,om2
25202 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
25203 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
25204       gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
25205              + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
25206              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25207       gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
25208        END DO
25209        RETURN
25210       END SUBROUTINE sc_grad_pepbase
25211       subroutine eprot_sc_phosphate(escpho)
25212       use calc_data
25213 !      implicit real*8 (a-h,o-z)
25214 !      include 'DIMENSIONS'
25215 !      include 'COMMON.GEO'
25216 !      include 'COMMON.VAR'
25217 !      include 'COMMON.LOCAL'
25218 !      include 'COMMON.CHAIN'
25219 !      include 'COMMON.DERIV'
25220 !      include 'COMMON.NAMES'
25221 !      include 'COMMON.INTERACT'
25222 !      include 'COMMON.IOUNITS'
25223 !      include 'COMMON.CALC'
25224 !      include 'COMMON.CONTROL'
25225 !      include 'COMMON.SBRIDGE'
25226       logical :: lprn
25227 !el local variables
25228       integer :: iint,itypi,itypi1,itypj,subchap
25229       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
25230       real(kind=8) :: evdw,sig0ij,aa,bb
25231       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25232                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
25233                 sslipi,sslipj,faclip,alpha_sco
25234       integer :: ii
25235       real(kind=8) :: fracinbuf
25236        real (kind=8) :: escpho
25237        real (kind=8),dimension(4):: ener
25238        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
25239        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
25240       sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
25241       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
25242       dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
25243       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
25244       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
25245       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
25246        real(kind=8),dimension(3,2)::chead,erhead_tail
25247        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
25248        integer troll
25249        eps_out=80.0d0
25250        escpho=0.0d0
25251 !       do i=1,nres_molec(1)
25252       do i=ibond_start,ibond_end
25253       if (itype(i,1).eq.ntyp1_molec(1)) cycle
25254       itypi  = itype(i,1)
25255       dxi    = dc_norm(1,nres+i)
25256       dyi    = dc_norm(2,nres+i)
25257       dzi    = dc_norm(3,nres+i)
25258       dsci_inv = vbld_inv(i+nres)
25259       xi=c(1,nres+i)
25260       yi=c(2,nres+i)
25261       zi=c(3,nres+i)
25262        call to_box(xi,yi,zi)
25263       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
25264        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
25265          itypj= itype(j,2)
25266          if ((itype(j,2).eq.ntyp1_molec(2)).or.&
25267           (itype(j+1,2).eq.ntyp1_molec(2))) cycle
25268          xj=(c(1,j)+c(1,j+1))/2.0
25269          yj=(c(2,j)+c(2,j+1))/2.0
25270          zj=(c(3,j)+c(3,j+1))/2.0
25271      call to_box(xj,yj,zj)
25272 !     call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
25273 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
25274 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
25275 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
25276 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
25277       xj=boxshift(xj-xi,boxxsize)
25278       yj=boxshift(yj-yi,boxysize)
25279       zj=boxshift(zj-zi,boxzsize)
25280           dxj = dc_norm( 1,j )
25281         dyj = dc_norm( 2,j )
25282         dzj = dc_norm( 3,j )
25283         dscj_inv = vbld_inv(j+1)
25284
25285 ! Gay-berne var's
25286         sig0ij = sigma_scpho(itypi )
25287         chi1   = chi_scpho(itypi,1 )
25288         chi2   = chi_scpho(itypi,2 )
25289 !          chi1=0.0d0
25290 !          chi2=0.0d0
25291         chi12  = chi1 * chi2
25292         chip1  = chipp_scpho(itypi,1 )
25293         chip2  = chipp_scpho(itypi,2 )
25294 !          chip1=0.0d0
25295 !          chip2=0.0d0
25296         chip12 = chip1 * chip2
25297         chis1 = chis_scpho(itypi,1)
25298         chis2 = chis_scpho(itypi,2)
25299         chis12 = chis1 * chis2
25300         sig1 = sigmap1_scpho(itypi)
25301         sig2 = sigmap2_scpho(itypi)
25302 !       write (*,*) "sig1 = ", sig1
25303 !       write (*,*) "sig1 = ", sig1
25304 !       write (*,*) "sig2 = ", sig2
25305 ! alpha factors from Fcav/Gcav
25306         alf1   = 0.0d0
25307         alf2   = 0.0d0
25308         alf12  = 0.0d0
25309         a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
25310
25311         b1 = alphasur_scpho(1,itypi)
25312 !          b1=0.0d0
25313         b2 = alphasur_scpho(2,itypi)
25314         b3 = alphasur_scpho(3,itypi)
25315         b4 = alphasur_scpho(4,itypi)
25316 ! used to determine whether we want to do quadrupole calculations
25317 ! used by Fgb
25318        eps_in = epsintab_scpho(itypi)
25319        if (eps_in.eq.0.0) eps_in=1.0
25320        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
25321 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
25322 !-------------------------------------------------------------------
25323 ! tail location and distance calculations
25324         d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
25325         d1j = 0.0
25326        DO k = 1,3
25327 ! location of polar head is computed by taking hydrophobic centre
25328 ! and moving by a d1 * dc_norm vector
25329 ! see unres publications for very informative images
25330       chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
25331       chead(k,2) = (c(k, j) + c(k, j+1))/2.0
25332 ! distance
25333 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25334 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25335       Rhead_distance(k) = chead(k,2) - chead(k,1)
25336        END DO
25337 ! pitagoras (root of sum of squares)
25338        Rhead = dsqrt( &
25339         (Rhead_distance(1)*Rhead_distance(1)) &
25340       + (Rhead_distance(2)*Rhead_distance(2)) &
25341       + (Rhead_distance(3)*Rhead_distance(3)))
25342        Rhead_sq=Rhead**2.0
25343 !-------------------------------------------------------------------
25344 ! zero everything that should be zero'ed
25345        evdwij = 0.0d0
25346        ECL = 0.0d0
25347        Elj = 0.0d0
25348        Equad = 0.0d0
25349        Epol = 0.0d0
25350        Fcav=0.0d0
25351        eheadtail = 0.0d0
25352        dGCLdR=0.0d0
25353        dGCLdOM1 = 0.0d0
25354        dGCLdOM2 = 0.0d0
25355        dGCLdOM12 = 0.0d0
25356        dPOLdOM1 = 0.0d0
25357        dPOLdOM2 = 0.0d0
25358         Fcav = 0.0d0
25359         dFdR = 0.0d0
25360         dCAVdOM1  = 0.0d0
25361         dCAVdOM2  = 0.0d0
25362         dCAVdOM12 = 0.0d0
25363         dscj_inv = vbld_inv(j+1)/2.0
25364 !dhead_scbasej(itypi,itypj)
25365 !          print *,i,j,dscj_inv,dsci_inv
25366 ! rij holds 1/(distance of Calpha atoms)
25367         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25368         rij  = dsqrt(rrij)
25369 !----------------------------
25370         CALL sc_angular
25371 ! this should be in elgrad_init but om's are calculated by sc_angular
25372 ! which in turn is used by older potentials
25373 ! om = omega, sqom = om^2
25374         sqom1  = om1 * om1
25375         sqom2  = om2 * om2
25376         sqom12 = om12 * om12
25377
25378 ! now we calculate EGB - Gey-Berne
25379 ! It will be summed up in evdwij and saved in evdw
25380         sigsq     = 1.0D0  / sigsq
25381         sig       = sig0ij * dsqrt(sigsq)
25382 !          rij_shift = 1.0D0  / rij - sig + sig0ij
25383         rij_shift = 1.0/rij - sig + sig0ij
25384         IF (rij_shift.le.0.0D0) THEN
25385          evdw = 1.0D20
25386          RETURN
25387         END IF
25388         sigder = -sig * sigsq
25389         rij_shift = 1.0D0 / rij_shift
25390         fac       = rij_shift**expon
25391         c1        = fac  * fac * aa_scpho(itypi)
25392 !          c1        = 0.0d0
25393         c2        = fac  * bb_scpho(itypi)
25394 !          c2        = 0.0d0
25395         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
25396         eps2der   = eps3rt * evdwij
25397         eps3der   = eps2rt * evdwij
25398 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
25399         evdwij    = eps2rt * eps3rt * evdwij
25400         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
25401         fac    = -expon * (c1 + evdwij) * rij_shift
25402         sigder = fac * sigder
25403 !          fac    = rij * fac
25404 ! Calculate distance derivative
25405         gg(1) =  fac
25406         gg(2) =  fac
25407         gg(3) =  fac
25408         fac = chis1 * sqom1 + chis2 * sqom2 &
25409         - 2.0d0 * chis12 * om1 * om2 * om12
25410 ! we will use pom later in Gcav, so dont mess with it!
25411         pom = 1.0d0 - chis1 * chis2 * sqom12
25412         Lambf = (1.0d0 - (fac / pom))
25413         Lambf = dsqrt(Lambf)
25414         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
25415 !       write (*,*) "sparrow = ", sparrow
25416         Chif = 1.0d0/rij * sparrow
25417         ChiLambf = Chif * Lambf
25418         eagle = dsqrt(ChiLambf)
25419         bat = ChiLambf ** 11.0d0
25420         top = b1 * ( eagle + b2 * ChiLambf - b3 )
25421         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
25422         botsq = bot * bot
25423         Fcav = top / bot
25424         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
25425         dbot = 12.0d0 * b4 * bat * Lambf
25426         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25427 !       dFdR = 0.0d0
25428 !      write (*,*) "dFcav/dR = ", dFdR
25429         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
25430         dbot = 12.0d0 * b4 * bat * Chif
25431         eagle = Lambf * pom
25432         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25433         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25434         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25435             * (chis2 * om2 * om12 - om1) / (eagle * pom)
25436
25437         dFdL = ((dtop * bot - top * dbot) / botsq)
25438 !       dFdL = 0.0d0
25439         dCAVdOM1  = dFdL * ( dFdOM1 )
25440         dCAVdOM2  = dFdL * ( dFdOM2 )
25441         dCAVdOM12 = dFdL * ( dFdOM12 )
25442
25443         ertail(1) = xj*rij
25444         ertail(2) = yj*rij
25445         ertail(3) = zj*rij
25446        DO k = 1, 3
25447 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25448 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25449 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
25450
25451       pom = ertail(k)
25452 !        print *,pom,gg(k),dFdR
25453 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25454       gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
25455               - (( dFdR + gg(k) ) * pom)
25456 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
25457 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25458 !     &             - ( dFdR * pom )
25459 !        pom = ertail(k)
25460 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25461 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
25462 !                  + (( dFdR + gg(k) ) * pom)
25463 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25464 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25465 !c!     &             + ( dFdR * pom )
25466
25467       gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
25468               - (( dFdR + gg(k) ) * ertail(k))
25469 !c!     &             - ( dFdR * ertail(k))
25470
25471       gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
25472               + (( dFdR + gg(k) ) * ertail(k))/2.0
25473
25474       gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
25475               + (( dFdR + gg(k) ) * ertail(k))/2.0
25476
25477 !c!     &             + ( dFdR * ertail(k))
25478
25479       gg(k) = 0.0d0
25480       ENDDO
25481 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25482 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25483 !      alphapol1 = alphapol_scpho(itypi)
25484        if (wqq_scpho(itypi).ne.0.0) then
25485        Qij=wqq_scpho(itypi)/eps_in
25486        alpha_sco=1.d0/alphi_scpho(itypi)
25487 !       Qij=0.0
25488        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
25489 !c! derivative of Ecl is Gcl...
25490        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
25491             (Rhead*alpha_sco+1) ) / Rhead_sq
25492        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
25493        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
25494        w1        = wqdip_scpho(1,itypi)
25495        w2        = wqdip_scpho(2,itypi)
25496 !       w1=0.0d0
25497 !       w2=0.0d0
25498 !       pis       = sig0head_scbase(itypi,itypj)
25499 !       eps_head   = epshead_scbase(itypi,itypj)
25500 !c!-------------------------------------------------------------------
25501
25502 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25503 !c!     &        +dhead(1,1,itypi,itypj))**2))
25504 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25505 !c!     &        +dhead(2,1,itypi,itypj))**2))
25506
25507 !c!-------------------------------------------------------------------
25508 !c! ecl
25509        sparrow  = w1  *  om1
25510        hawk     = w2 *  (1.0d0 - sqom2)
25511        Ecl = sparrow / Rhead**2.0d0 &
25512          - hawk    / Rhead**4.0d0
25513 !c!-------------------------------------------------------------------
25514        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
25515          1.0/rij,sparrow
25516
25517 !c! derivative of ecl is Gcl
25518 !c! dF/dr part
25519        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
25520             + 4.0d0 * hawk    / Rhead**5.0d0
25521 !c! dF/dom1
25522        dGCLdOM1 = (w1) / (Rhead**2.0d0)
25523 !c! dF/dom2
25524        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
25525        endif
25526
25527 !c--------------------------------------------------------------------
25528 !c Polarization energy
25529 !c Epol
25530        R1 = 0.0d0
25531        DO k = 1, 3
25532 !c! Calculate head-to-tail distances tail is center of side-chain
25533       R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
25534        END DO
25535 !c! Pitagoras
25536        R1 = dsqrt(R1)
25537
25538       alphapol1 = alphapol_scpho(itypi)
25539 !      alphapol1=0.0
25540        MomoFac1 = (1.0d0 - chi2 * sqom1)
25541        RR1  = R1 * R1 / MomoFac1
25542        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25543 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
25544        fgb1 = sqrt( RR1 + a12sq * ee1)
25545 !       eps_inout_fac=0.0d0
25546        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
25547 ! derivative of Epol is Gpol...
25548        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
25549             / (fgb1 ** 5.0d0)
25550        dFGBdR1 = ( (R1 / MomoFac1) &
25551            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
25552            / ( 2.0d0 * fgb1 )
25553        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25554              * (2.0d0 - 0.5d0 * ee1) ) &
25555              / (2.0d0 * fgb1)
25556        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25557 !       dPOLdR1 = 0.0d0
25558 !       dPOLdOM1 = 0.0d0
25559        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
25560              * (2.0d0 - 0.5d0 * ee1) ) &
25561              / (2.0d0 * fgb1)
25562
25563        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
25564        dPOLdOM2 = 0.0
25565        DO k = 1, 3
25566       erhead(k) = Rhead_distance(k)/Rhead
25567       erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
25568        END DO
25569
25570        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25571        erdxj = scalar( erhead(1), dC_norm(1,j) )
25572        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25573 !       bat=0.0d0
25574        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
25575        facd1 = d1i * vbld_inv(i+nres)
25576        facd2 = d1j * vbld_inv(j)
25577 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25578
25579        DO k = 1, 3
25580       hawk = (erhead_tail(k,1) + &
25581       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
25582 !        facd1=0.0d0
25583 !        facd2=0.0d0
25584 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
25585 !                pom,(erhead_tail(k,1))
25586
25587 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
25588       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25589       gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
25590                - dGCLdR * pom &
25591                - dPOLdR1 *  (erhead_tail(k,1))
25592 !     &             - dGLJdR * pom
25593
25594       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
25595 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
25596 !                   + dGCLdR * pom  &
25597 !                   + dPOLdR1 * (erhead_tail(k,1))
25598 !     &             + dGLJdR * pom
25599
25600
25601       gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
25602               - dGCLdR * erhead(k) &
25603               - dPOLdR1 * erhead_tail(k,1)
25604 !     &             - dGLJdR * erhead(k)
25605
25606       gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
25607               + (dGCLdR * erhead(k)  &
25608               + dPOLdR1 * erhead_tail(k,1))/2.0
25609       gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
25610               + (dGCLdR * erhead(k)  &
25611               + dPOLdR1 * erhead_tail(k,1))/2.0
25612
25613 !     &             + dGLJdR * erhead(k)
25614 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
25615
25616        END DO
25617 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
25618        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
25619       "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
25620        escpho=escpho+evdwij+epol+Fcav+ECL
25621        call sc_grad_scpho
25622        enddo
25623
25624       enddo
25625
25626       return
25627       end subroutine eprot_sc_phosphate
25628       SUBROUTINE sc_grad_scpho
25629       use calc_data
25630
25631        real (kind=8) :: dcosom1(3),dcosom2(3)
25632        eom1  =    &
25633             eps2der * eps2rt_om1   &
25634           - 2.0D0 * alf1 * eps3der &
25635           + sigder * sigsq_om1     &
25636           + dCAVdOM1               &
25637           + dGCLdOM1               &
25638           + dPOLdOM1
25639
25640        eom2  =  &
25641             eps2der * eps2rt_om2   &
25642           + 2.0D0 * alf2 * eps3der &
25643           + sigder * sigsq_om2     &
25644           + dCAVdOM2               &
25645           + dGCLdOM2               &
25646           + dPOLdOM2
25647
25648        eom12 =    &
25649             evdwij  * eps1_om12     &
25650           + eps2der * eps2rt_om12   &
25651           - 2.0D0 * alf12 * eps3der &
25652           + sigder *sigsq_om12      &
25653           + dCAVdOM12               &
25654           + dGCLdOM12
25655 !        om12=0.0
25656 !        eom12=0.0
25657 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
25658 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
25659 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
25660 !                 *dsci_inv*2.0
25661 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
25662 !               gg(1),gg(2),"rozne"
25663        DO k = 1, 3
25664       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25665       dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
25666       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25667       gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
25668              + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
25669              *dscj_inv*2.0 &
25670              - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25671       gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
25672              - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
25673              *dscj_inv*2.0 &
25674              + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25675       gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
25676              + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
25677              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25678
25679 !         print *,eom12,eom2,om12,om2
25680 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
25681 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
25682 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
25683 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
25684 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25685       gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
25686        END DO
25687        RETURN
25688       END SUBROUTINE sc_grad_scpho
25689       subroutine eprot_pep_phosphate(epeppho)
25690       use calc_data
25691 !      implicit real*8 (a-h,o-z)
25692 !      include 'DIMENSIONS'
25693 !      include 'COMMON.GEO'
25694 !      include 'COMMON.VAR'
25695 !      include 'COMMON.LOCAL'
25696 !      include 'COMMON.CHAIN'
25697 !      include 'COMMON.DERIV'
25698 !      include 'COMMON.NAMES'
25699 !      include 'COMMON.INTERACT'
25700 !      include 'COMMON.IOUNITS'
25701 !      include 'COMMON.CALC'
25702 !      include 'COMMON.CONTROL'
25703 !      include 'COMMON.SBRIDGE'
25704       logical :: lprn
25705 !el local variables
25706       integer :: iint,itypi,itypi1,itypj,subchap
25707       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
25708       real(kind=8) :: evdw,sig0ij
25709       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25710                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
25711                 sslipi,sslipj,faclip
25712       integer :: ii
25713       real(kind=8) :: fracinbuf
25714        real (kind=8) :: epeppho
25715        real (kind=8),dimension(4):: ener
25716        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
25717        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
25718       sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
25719       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
25720       dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
25721       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
25722       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
25723       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
25724        real(kind=8),dimension(3,2)::chead,erhead_tail
25725        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
25726        integer troll
25727        real (kind=8) :: dcosom1(3),dcosom2(3)
25728        epeppho=0.0d0
25729 !       do i=1,nres_molec(1)
25730       do i=ibond_start,ibond_end
25731       if (itype(i,1).eq.ntyp1_molec(1)) cycle
25732       itypi  = itype(i,1)
25733       dsci_inv = vbld_inv(i+1)/2.0
25734       dxi    = dc_norm(1,i)
25735       dyi    = dc_norm(2,i)
25736       dzi    = dc_norm(3,i)
25737       xi=(c(1,i)+c(1,i+1))/2.0
25738       yi=(c(2,i)+c(2,i+1))/2.0
25739       zi=(c(3,i)+c(3,i+1))/2.0
25740                call to_box(xi,yi,zi)
25741
25742         do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
25743          itypj= itype(j,2)
25744          if ((itype(j,2).eq.ntyp1_molec(2)).or.&
25745           (itype(j+1,2).eq.ntyp1_molec(2))) cycle
25746          xj=(c(1,j)+c(1,j+1))/2.0
25747          yj=(c(2,j)+c(2,j+1))/2.0
25748          zj=(c(3,j)+c(3,j+1))/2.0
25749                 call to_box(xj,yj,zj)
25750       xj=boxshift(xj-xi,boxxsize)
25751       yj=boxshift(yj-yi,boxysize)
25752       zj=boxshift(zj-zi,boxzsize)
25753
25754         dist_init=xj**2+yj**2+zj**2
25755         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25756         rij  = dsqrt(rrij)
25757         dxj = dc_norm( 1,j )
25758         dyj = dc_norm( 2,j )
25759         dzj = dc_norm( 3,j )
25760         dscj_inv = vbld_inv(j+1)/2.0
25761 ! Gay-berne var's
25762         sig0ij = sigma_peppho
25763 !          chi1=0.0d0
25764 !          chi2=0.0d0
25765         chi12  = chi1 * chi2
25766 !          chip1=0.0d0
25767 !          chip2=0.0d0
25768         chip12 = chip1 * chip2
25769 !          chis1 = 0.0d0
25770 !          chis2 = 0.0d0
25771         chis12 = chis1 * chis2
25772         sig1 = sigmap1_peppho
25773         sig2 = sigmap2_peppho
25774 !       write (*,*) "sig1 = ", sig1
25775 !       write (*,*) "sig1 = ", sig1
25776 !       write (*,*) "sig2 = ", sig2
25777 ! alpha factors from Fcav/Gcav
25778         alf1   = 0.0d0
25779         alf2   = 0.0d0
25780         alf12  = 0.0d0
25781         b1 = alphasur_peppho(1)
25782 !          b1=0.0d0
25783         b2 = alphasur_peppho(2)
25784         b3 = alphasur_peppho(3)
25785         b4 = alphasur_peppho(4)
25786         CALL sc_angular
25787        sqom1=om1*om1
25788        evdwij = 0.0d0
25789        ECL = 0.0d0
25790        Elj = 0.0d0
25791        Equad = 0.0d0
25792        Epol = 0.0d0
25793        Fcav=0.0d0
25794        eheadtail = 0.0d0
25795        dGCLdR=0.0d0
25796        dGCLdOM1 = 0.0d0
25797        dGCLdOM2 = 0.0d0
25798        dGCLdOM12 = 0.0d0
25799        dPOLdOM1 = 0.0d0
25800        dPOLdOM2 = 0.0d0
25801         Fcav = 0.0d0
25802         dFdR = 0.0d0
25803         dCAVdOM1  = 0.0d0
25804         dCAVdOM2  = 0.0d0
25805         dCAVdOM12 = 0.0d0
25806         rij_shift = rij
25807         fac       = rij_shift**expon
25808         c1        = fac  * fac * aa_peppho
25809 !          c1        = 0.0d0
25810         c2        = fac  * bb_peppho
25811 !          c2        = 0.0d0
25812         evdwij    =  c1 + c2
25813 ! Now cavity....................
25814        eagle = dsqrt(1.0/rij_shift)
25815        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
25816         bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
25817         botsq = bot * bot
25818         Fcav = top / bot
25819         dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
25820         dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
25821         dFdR = ((dtop * bot - top * dbot) / botsq)
25822        w1        = wqdip_peppho(1)
25823        w2        = wqdip_peppho(2)
25824 !       w1=0.0d0
25825 !       w2=0.0d0
25826 !       pis       = sig0head_scbase(itypi,itypj)
25827 !       eps_head   = epshead_scbase(itypi,itypj)
25828 !c!-------------------------------------------------------------------
25829
25830 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25831 !c!     &        +dhead(1,1,itypi,itypj))**2))
25832 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25833 !c!     &        +dhead(2,1,itypi,itypj))**2))
25834
25835 !c!-------------------------------------------------------------------
25836 !c! ecl
25837        sparrow  = w1  *  om1
25838        hawk     = w2 *  (1.0d0 - sqom1)
25839        Ecl = sparrow * rij_shift**2.0d0 &
25840          - hawk    * rij_shift**4.0d0
25841 !c!-------------------------------------------------------------------
25842 !c! derivative of ecl is Gcl
25843 !c! dF/dr part
25844 !       rij_shift=5.0
25845        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
25846             + 4.0d0 * hawk    * rij_shift**5.0d0
25847 !c! dF/dom1
25848        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
25849 !c! dF/dom2
25850        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
25851        eom1  =    dGCLdOM1+dGCLdOM2
25852        eom2  =    0.0
25853
25854         fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
25855 !          fac=0.0
25856         gg(1) =  fac*xj*rij
25857         gg(2) =  fac*yj*rij
25858         gg(3) =  fac*zj*rij
25859        do k=1,3
25860        gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
25861        gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
25862        gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
25863        gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
25864        gg(k)=0.0
25865        enddo
25866
25867       DO k = 1, 3
25868       dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
25869       dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
25870       gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
25871       gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
25872 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25873       gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
25874 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25875       gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
25876              - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25877       gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
25878              + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25879       enddo
25880        epeppho=epeppho+evdwij+Fcav+ECL
25881 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
25882        enddo
25883        enddo
25884       end subroutine eprot_pep_phosphate
25885 !!!!!!!!!!!!!!!!-------------------------------------------------------------
25886       subroutine emomo(evdw)
25887       use calc_data
25888       use comm_momo
25889 !      implicit real*8 (a-h,o-z)
25890 !      include 'DIMENSIONS'
25891 !      include 'COMMON.GEO'
25892 !      include 'COMMON.VAR'
25893 !      include 'COMMON.LOCAL'
25894 !      include 'COMMON.CHAIN'
25895 !      include 'COMMON.DERIV'
25896 !      include 'COMMON.NAMES'
25897 !      include 'COMMON.INTERACT'
25898 !      include 'COMMON.IOUNITS'
25899 !      include 'COMMON.CALC'
25900 !      include 'COMMON.CONTROL'
25901 !      include 'COMMON.SBRIDGE'
25902       logical :: lprn
25903 !el local variables
25904       integer :: iint,itypi1,subchap,isel
25905       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
25906       real(kind=8) :: evdw,aa,bb
25907       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25908                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
25909                 sslipi,sslipj,faclip,alpha_sco
25910       integer :: ii
25911       real(kind=8) :: fracinbuf
25912        real (kind=8) :: escpho
25913        real (kind=8),dimension(4):: ener
25914        real(kind=8) :: b1,b2,egb
25915        real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
25916       Lambf,&
25917       Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
25918       dFdOM2,dFdL,dFdOM12,&
25919       federmaus,&
25920       d1i,d1j
25921 !       real(kind=8),dimension(3,2)::erhead_tail
25922 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
25923        real(kind=8) ::  facd4, adler, Fgb, facd3
25924        integer troll,jj,istate
25925        real (kind=8) :: dcosom1(3),dcosom2(3)
25926        evdw=0.0d0
25927        eps_out=80.0d0
25928        sss_ele_cut=1.0d0
25929 !       print *,"EVDW KURW",evdw,nres
25930       do i=iatsc_s,iatsc_e
25931 !        print *,"I am in EVDW",i
25932       itypi=iabs(itype(i,1))
25933 !        if (i.ne.47) cycle
25934       if (itypi.eq.ntyp1) cycle
25935       itypi1=iabs(itype(i+1,1))
25936       xi=c(1,nres+i)
25937       yi=c(2,nres+i)
25938       zi=c(3,nres+i)
25939         call to_box(xi,yi,zi)
25940         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
25941        if ((zi.gt.bordlipbot)  &
25942       .and.(zi.lt.bordliptop)) then
25943 !C the energy transfer exist
25944       if (zi.lt.buflipbot) then
25945 !C what fraction I am in
25946        fracinbuf=1.0d0-  &
25947             ((zi-bordlipbot)/lipbufthick)
25948 !C lipbufthick is thickenes of lipid buffore
25949        sslipi=sscalelip(fracinbuf)
25950        ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
25951       elseif (zi.gt.bufliptop) then
25952        fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
25953        sslipi=sscalelip(fracinbuf)
25954        ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
25955       else
25956        sslipi=1.0d0
25957        ssgradlipi=0.0
25958       endif
25959        else
25960        sslipi=0.0d0
25961        ssgradlipi=0.0
25962        endif
25963 !       print *, sslipi,ssgradlipi
25964       dxi=dc_norm(1,nres+i)
25965       dyi=dc_norm(2,nres+i)
25966       dzi=dc_norm(3,nres+i)
25967 !        dsci_inv=dsc_inv(itypi)
25968       dsci_inv=vbld_inv(i+nres)
25969 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
25970 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
25971 !
25972 ! Calculate SC interaction energy.
25973 !
25974       do iint=1,nint_gr(i)
25975         do j=istart(i,iint),iend(i,iint)
25976 !             print *,"JA PIER",i,j,iint,istart(i,iint),iend(i,iint)
25977           IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
25978             call dyn_ssbond_ene(i,j,evdwij)
25979             evdw=evdw+evdwij
25980             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25981                         'evdw',i,j,evdwij,' ss'
25982 !              if (energy_dec) write (iout,*) &
25983 !                              'evdw',i,j,evdwij,' ss'
25984            do k=j+1,iend(i,iint)
25985 !C search over all next residues
25986             if (dyn_ss_mask(k)) then
25987 !C check if they are cysteins
25988 !C              write(iout,*) 'k=',k
25989
25990 !c              write(iout,*) "PRZED TRI", evdwij
25991 !               evdwij_przed_tri=evdwij
25992             call triple_ssbond_ene(i,j,k,evdwij)
25993 !c               if(evdwij_przed_tri.ne.evdwij) then
25994 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
25995 !c               endif
25996
25997 !c              write(iout,*) "PO TRI", evdwij
25998 !C call the energy function that removes the artifical triple disulfide
25999 !C bond the soubroutine is located in ssMD.F
26000             evdw=evdw+evdwij
26001             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
26002                       'evdw',i,j,evdwij,'tss'
26003             endif!dyn_ss_mask(k)
26004            enddo! k
26005           ELSE
26006 !el            ind=ind+1
26007           itypj=iabs(itype(j,1))
26008           if (itypj.eq.ntyp1) cycle
26009            CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
26010
26011 !             if (j.ne.78) cycle
26012 !            dscj_inv=dsc_inv(itypj)
26013           dscj_inv=vbld_inv(j+nres)
26014          xj=c(1,j+nres)
26015          yj=c(2,j+nres)
26016          zj=c(3,j+nres)
26017      call to_box(xj,yj,zj)
26018      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
26019       write(iout,*) "KRUWA", i,j
26020       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
26021       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
26022       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
26023       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
26024       xj=boxshift(xj-xi,boxxsize)
26025       yj=boxshift(yj-yi,boxysize)
26026       zj=boxshift(zj-zi,boxzsize)
26027         dxj = dc_norm( 1, nres+j )
26028         dyj = dc_norm( 2, nres+j )
26029         dzj = dc_norm( 3, nres+j )
26030 !          print *,i,j,itypi,itypj
26031 !          d1i=0.0d0
26032 !          d1j=0.0d0
26033 !          BetaT = 1.0d0 / (298.0d0 * Rb)
26034 ! Gay-berne var's
26035 !1!          sig0ij = sigma_scsc( itypi,itypj )
26036 !          chi1=0.0d0
26037 !          chi2=0.0d0
26038 !          chip1=0.0d0
26039 !          chip2=0.0d0
26040 ! not used by momo potential, but needed by sc_angular which is shared
26041 ! by all energy_potential subroutines
26042         alf1   = 0.0d0
26043         alf2   = 0.0d0
26044         alf12  = 0.0d0
26045         a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
26046 !       a12sq = a12sq * a12sq
26047 ! charge of amino acid itypi is...
26048         chis1 = chis(itypi,itypj)
26049         chis2 = chis(itypj,itypi)
26050         chis12 = chis1 * chis2
26051         sig1 = sigmap1(itypi,itypj)
26052         sig2 = sigmap2(itypi,itypj)
26053 !       write (*,*) "sig1 = ", sig1
26054 !          chis1=0.0
26055 !          chis2=0.0
26056 !                    chis12 = chis1 * chis2
26057 !          sig1=0.0
26058 !          sig2=0.0
26059 !       write (*,*) "sig2 = ", sig2
26060 ! alpha factors from Fcav/Gcav
26061         b1cav = alphasur(1,itypi,itypj)
26062 !          b1cav=0.0d0
26063         b2cav = alphasur(2,itypi,itypj)
26064         b3cav = alphasur(3,itypi,itypj)
26065         b4cav = alphasur(4,itypi,itypj)
26066 ! used to determine whether we want to do quadrupole calculations
26067        eps_in = epsintab(itypi,itypj)
26068        if (eps_in.eq.0.0) eps_in=1.0
26069
26070        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
26071        Rtail = 0.0d0
26072 !       dtail(1,itypi,itypj)=0.0
26073 !       dtail(2,itypi,itypj)=0.0
26074
26075        DO k = 1, 3
26076       ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
26077       ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
26078        END DO
26079 !c! tail distances will be themselves usefull elswhere
26080 !c1 (in Gcav, for example)
26081        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
26082        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
26083        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
26084        Rtail = dsqrt( &
26085         (Rtail_distance(1)*Rtail_distance(1)) &
26086       + (Rtail_distance(2)*Rtail_distance(2)) &
26087       + (Rtail_distance(3)*Rtail_distance(3)))
26088
26089 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
26090 !-------------------------------------------------------------------
26091 ! tail location and distance calculations
26092        d1 = dhead(1, 1, itypi, itypj)
26093        d2 = dhead(2, 1, itypi, itypj)
26094
26095        DO k = 1,3
26096 ! location of polar head is computed by taking hydrophobic centre
26097 ! and moving by a d1 * dc_norm vector
26098 ! see unres publications for very informative images
26099       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
26100       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
26101 ! distance
26102 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
26103 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
26104       Rhead_distance(k) = chead(k,2) - chead(k,1)
26105        END DO
26106 ! pitagoras (root of sum of squares)
26107        Rhead = dsqrt( &
26108         (Rhead_distance(1)*Rhead_distance(1)) &
26109       + (Rhead_distance(2)*Rhead_distance(2)) &
26110       + (Rhead_distance(3)*Rhead_distance(3)))
26111 !-------------------------------------------------------------------
26112 ! zero everything that should be zero'ed
26113        evdwij = 0.0d0
26114        ECL = 0.0d0
26115        Elj = 0.0d0
26116        Equad = 0.0d0
26117        Epol = 0.0d0
26118        Fcav=0.0d0
26119        eheadtail = 0.0d0
26120        dGCLdOM1 = 0.0d0
26121        dGCLdOM2 = 0.0d0
26122        dGCLdOM12 = 0.0d0
26123        dPOLdOM1 = 0.0d0
26124        dPOLdOM2 = 0.0d0
26125         Fcav = 0.0d0
26126         dFdR = 0.0d0
26127         dCAVdOM1  = 0.0d0
26128         dCAVdOM2  = 0.0d0
26129         dCAVdOM12 = 0.0d0
26130         dscj_inv = vbld_inv(j+nres)
26131 !          print *,i,j,dscj_inv,dsci_inv
26132 ! rij holds 1/(distance of Calpha atoms)
26133         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
26134         rij  = dsqrt(rrij)
26135 !----------------------------
26136         CALL sc_angular
26137 ! this should be in elgrad_init but om's are calculated by sc_angular
26138 ! which in turn is used by older potentials
26139 ! om = omega, sqom = om^2
26140         sqom1  = om1 * om1
26141         sqom2  = om2 * om2
26142         sqom12 = om12 * om12
26143
26144 ! now we calculate EGB - Gey-Berne
26145 ! It will be summed up in evdwij and saved in evdw
26146         sigsq     = 1.0D0  / sigsq
26147         sig       = sig0ij * dsqrt(sigsq)
26148 !          rij_shift = 1.0D0  / rij - sig + sig0ij
26149         rij_shift = Rtail - sig + sig0ij
26150         IF (rij_shift.le.0.0D0) THEN
26151          evdw = 1.0D20
26152          RETURN
26153         END IF
26154         sigder = -sig * sigsq
26155         rij_shift = 1.0D0 / rij_shift
26156         fac       = rij_shift**expon
26157         c1        = fac  * fac * aa_aq(itypi,itypj)
26158 !          print *,"ADAM",aa_aq(itypi,itypj)
26159
26160 !          c1        = 0.0d0
26161         c2        = fac  * bb_aq(itypi,itypj)
26162 !          c2        = 0.0d0
26163         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
26164         eps2der   = eps3rt * evdwij
26165         eps3der   = eps2rt * evdwij
26166 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
26167         evdwij    = eps2rt * eps3rt * evdwij
26168 !#ifdef TSCSC
26169 !          IF (bb_aq(itypi,itypj).gt.0) THEN
26170 !           evdw_p = evdw_p + evdwij
26171 !          ELSE
26172 !           evdw_m = evdw_m + evdwij
26173 !          END IF
26174 !#else
26175         evdw = evdw  &
26176             + evdwij
26177 !#endif
26178
26179         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
26180         fac    = -expon * (c1 + evdwij) * rij_shift
26181         sigder = fac * sigder
26182 !          fac    = rij * fac
26183 ! Calculate distance derivative
26184         gg(1) =  fac
26185         gg(2) =  fac
26186         gg(3) =  fac
26187 !          if (b2.gt.0.0) then
26188         fac = chis1 * sqom1 + chis2 * sqom2 &
26189         - 2.0d0 * chis12 * om1 * om2 * om12
26190 ! we will use pom later in Gcav, so dont mess with it!
26191         pom = 1.0d0 - chis1 * chis2 * sqom12
26192         Lambf = (1.0d0 - (fac / pom))
26193 !          print *,"fac,pom",fac,pom,Lambf
26194         Lambf = dsqrt(Lambf)
26195         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
26196 !          print *,"sig1,sig2",sig1,sig2,itypi,itypj
26197 !       write (*,*) "sparrow = ", sparrow
26198         Chif = Rtail * sparrow
26199 !           print *,"rij,sparrow",rij , sparrow
26200         ChiLambf = Chif * Lambf
26201         eagle = dsqrt(ChiLambf)
26202         bat = ChiLambf ** 11.0d0
26203         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
26204         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
26205         botsq = bot * bot
26206 !          print *,top,bot,"bot,top",ChiLambf,Chif
26207         Fcav = top / bot
26208
26209        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
26210        dbot = 12.0d0 * b4cav * bat * Lambf
26211        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
26212
26213         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
26214         dbot = 12.0d0 * b4cav * bat * Chif
26215         eagle = Lambf * pom
26216         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
26217         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
26218         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
26219             * (chis2 * om2 * om12 - om1) / (eagle * pom)
26220
26221         dFdL = ((dtop * bot - top * dbot) / botsq)
26222 !       dFdL = 0.0d0
26223         dCAVdOM1  = dFdL * ( dFdOM1 )
26224         dCAVdOM2  = dFdL * ( dFdOM2 )
26225         dCAVdOM12 = dFdL * ( dFdOM12 )
26226
26227        DO k= 1, 3
26228       ertail(k) = Rtail_distance(k)/Rtail
26229        END DO
26230        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
26231        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
26232        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26233        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26234        DO k = 1, 3
26235 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
26236 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
26237       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
26238       gvdwx(k,i) = gvdwx(k,i) &
26239               - (( dFdR + gg(k) ) * pom)
26240 !c!     &             - ( dFdR * pom )
26241       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
26242       gvdwx(k,j) = gvdwx(k,j)   &
26243               + (( dFdR + gg(k) ) * pom)
26244 !c!     &             + ( dFdR * pom )
26245
26246       gvdwc(k,i) = gvdwc(k,i)  &
26247               - (( dFdR + gg(k) ) * ertail(k))
26248 !c!     &             - ( dFdR * ertail(k))
26249
26250       gvdwc(k,j) = gvdwc(k,j) &
26251               + (( dFdR + gg(k) ) * ertail(k))
26252 !c!     &             + ( dFdR * ertail(k))
26253
26254       gg(k) = 0.0d0
26255 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
26256 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
26257       END DO
26258
26259
26260 !c! Compute head-head and head-tail energies for each state
26261
26262         isel = iabs(Qi) + iabs(Qj)
26263 ! double charge for Phophorylated! itype - 25,27,27
26264 !          if ((itype(i).eq.27).or.(itype(i).eq.26).or.(itype(i).eq.25)) then
26265 !            Qi=Qi*2
26266 !            Qij=Qij*2
26267 !           endif
26268 !          if ((itype(j).eq.27).or.(itype(j).eq.26).or.(itype(j).eq.25)) then
26269 !            Qj=Qj*2
26270 !            Qij=Qij*2
26271 !           endif
26272
26273 !          isel=0
26274         IF (isel.eq.0) THEN
26275 !c! No charges - do nothing
26276          eheadtail = 0.0d0
26277
26278         ELSE IF (isel.eq.4) THEN
26279 !c! Calculate dipole-dipole interactions
26280          CALL edd(ecl)
26281          eheadtail = ECL
26282 !           eheadtail = 0.0d0
26283
26284         ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
26285 !c! Charge-nonpolar interactions
26286         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26287           Qi=Qi*2
26288           Qij=Qij*2
26289          endif
26290         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26291           Qj=Qj*2
26292           Qij=Qij*2
26293          endif
26294
26295          CALL eqn(epol)
26296          eheadtail = epol
26297 !           eheadtail = 0.0d0
26298
26299         ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
26300 !c! Nonpolar-charge interactions
26301         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26302           Qi=Qi*2
26303           Qij=Qij*2
26304          endif
26305         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26306           Qj=Qj*2
26307           Qij=Qij*2
26308          endif
26309
26310          CALL enq(epol)
26311          eheadtail = epol
26312 !           eheadtail = 0.0d0
26313
26314         ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
26315 !c! Charge-dipole interactions
26316         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26317           Qi=Qi*2
26318           Qij=Qij*2
26319          endif
26320         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26321           Qj=Qj*2
26322           Qij=Qij*2
26323          endif
26324
26325          CALL eqd(ecl, elj, epol)
26326          eheadtail = ECL + elj + epol
26327 !           eheadtail = 0.0d0
26328
26329         ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
26330 !c! Dipole-charge interactions
26331         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26332           Qi=Qi*2
26333           Qij=Qij*2
26334          endif
26335         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26336           Qj=Qj*2
26337           Qij=Qij*2
26338          endif
26339          CALL edq(ecl, elj, epol)
26340         eheadtail = ECL + elj + epol
26341 !           eheadtail = 0.0d0
26342
26343         ELSE IF ((isel.eq.2.and.   &
26344              iabs(Qi).eq.1).and.  &
26345              nstate(itypi,itypj).eq.1) THEN
26346 !c! Same charge-charge interaction ( +/+ or -/- )
26347         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26348           Qi=Qi*2
26349           Qij=Qij*2
26350          endif
26351         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26352           Qj=Qj*2
26353           Qij=Qij*2
26354          endif
26355
26356          CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
26357          eheadtail = ECL + Egb + Epol + Fisocav + Elj
26358 !           eheadtail = 0.0d0
26359
26360         ELSE IF ((isel.eq.2.and.  &
26361              iabs(Qi).eq.1).and. &
26362              nstate(itypi,itypj).ne.1) THEN
26363 !c! Different charge-charge interaction ( +/- or -/+ )
26364         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26365           Qi=Qi*2
26366           Qij=Qij*2
26367          endif
26368         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26369           Qj=Qj*2
26370           Qij=Qij*2
26371          endif
26372
26373          CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
26374         END IF
26375        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
26376       evdw = evdw  + Fcav + eheadtail
26377
26378        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
26379       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
26380       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
26381       Equad,evdwij+Fcav+eheadtail,evdw
26382 !       evdw = evdw  + Fcav  + eheadtail
26383
26384       iF (nstate(itypi,itypj).eq.1) THEN
26385       CALL sc_grad
26386        END IF
26387 !c!-------------------------------------------------------------------
26388 !c! NAPISY KONCOWE
26389        END DO   ! j
26390       END DO    ! iint
26391        END DO     ! i
26392 !c      write (iout,*) "Number of loop steps in EGB:",ind
26393 !c      energy_dec=.false.
26394 !              print *,"EVDW KURW",evdw,nres
26395
26396        RETURN
26397       END SUBROUTINE emomo
26398 !C------------------------------------------------------------------------------------
26399       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
26400       use calc_data
26401       use comm_momo
26402        real (kind=8) ::  facd3, facd4, federmaus, adler,&
26403        Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
26404 !       integer :: k
26405 !c! Epol and Gpol analytical parameters
26406        alphapol1 = alphapol(itypi,itypj)
26407        alphapol2 = alphapol(itypj,itypi)
26408 !c! Fisocav and Gisocav analytical parameters
26409        al1  = alphiso(1,itypi,itypj)
26410        al2  = alphiso(2,itypi,itypj)
26411        al3  = alphiso(3,itypi,itypj)
26412        al4  = alphiso(4,itypi,itypj)
26413        csig = (1.0d0  &
26414          / dsqrt(sigiso1(itypi, itypj)**2.0d0 &
26415          + sigiso2(itypi,itypj)**2.0d0))
26416 !c!
26417        pis  = sig0head(itypi,itypj)
26418        eps_head = epshead(itypi,itypj)
26419        Rhead_sq = Rhead * Rhead
26420 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26421 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26422        R1 = 0.0d0
26423        R2 = 0.0d0
26424        DO k = 1, 3
26425 !c! Calculate head-to-tail distances needed by Epol
26426       R1=R1+(ctail(k,2)-chead(k,1))**2
26427       R2=R2+(chead(k,2)-ctail(k,1))**2
26428        END DO
26429 !c! Pitagoras
26430        R1 = dsqrt(R1)
26431        R2 = dsqrt(R2)
26432
26433 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26434 !c!     &        +dhead(1,1,itypi,itypj))**2))
26435 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26436 !c!     &        +dhead(2,1,itypi,itypj))**2))
26437
26438 !c!-------------------------------------------------------------------
26439 !c! Coulomb electrostatic interaction
26440        Ecl = (332.0d0 * Qij) / Rhead
26441 !c! derivative of Ecl is Gcl...
26442        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
26443        dGCLdOM1 = 0.0d0
26444        dGCLdOM2 = 0.0d0
26445        dGCLdOM12 = 0.0d0
26446        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26447        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26448        debkap=debaykap(itypi,itypj)
26449        Egb = -(332.0d0 * Qij *&
26450       (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
26451 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
26452 !c! Derivative of Egb is Ggb...
26453        dGGBdFGB = -(-332.0d0 * Qij * &
26454        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
26455        -(332.0d0 * Qij *&
26456       (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
26457        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
26458        dGGBdR = dGGBdFGB * dFGBdR
26459 !c!-------------------------------------------------------------------
26460 !c! Fisocav - isotropic cavity creation term
26461 !c! or "how much energy it costs to put charged head in water"
26462        pom = Rhead * csig
26463        top = al1 * (dsqrt(pom) + al2 * pom - al3)
26464        bot = (1.0d0 + al4 * pom**12.0d0)
26465        botsq = bot * bot
26466        FisoCav = top / bot
26467 !      write (*,*) "Rhead = ",Rhead
26468 !      write (*,*) "csig = ",csig
26469 !      write (*,*) "pom = ",pom
26470 !      write (*,*) "al1 = ",al1
26471 !      write (*,*) "al2 = ",al2
26472 !      write (*,*) "al3 = ",al3
26473 !      write (*,*) "al4 = ",al4
26474 !        write (*,*) "top = ",top
26475 !        write (*,*) "bot = ",bot
26476 !c! Derivative of Fisocav is GCV...
26477        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26478        dbot = 12.0d0 * al4 * pom ** 11.0d0
26479        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26480 !c!-------------------------------------------------------------------
26481 !c! Epol
26482 !c! Polarization energy - charged heads polarize hydrophobic "neck"
26483        MomoFac1 = (1.0d0 - chi1 * sqom2)
26484        MomoFac2 = (1.0d0 - chi2 * sqom1)
26485        RR1  = ( R1 * R1 ) / MomoFac1
26486        RR2  = ( R2 * R2 ) / MomoFac2
26487        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26488        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26489        fgb1 = sqrt( RR1 + a12sq * ee1 )
26490        fgb2 = sqrt( RR2 + a12sq * ee2 )
26491        epol = 332.0d0 * eps_inout_fac * ( &
26492       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26493 !c!       epol = 0.0d0
26494        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26495              / (fgb1 ** 5.0d0)
26496        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26497              / (fgb2 ** 5.0d0)
26498        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
26499            / ( 2.0d0 * fgb1 )
26500        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
26501            / ( 2.0d0 * fgb2 )
26502        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
26503             * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
26504        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
26505             * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
26506        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26507 !c!       dPOLdR1 = 0.0d0
26508        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26509 !c!       dPOLdR2 = 0.0d0
26510        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26511 !c!       dPOLdOM1 = 0.0d0
26512        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26513 !c!       dPOLdOM2 = 0.0d0
26514 !c!-------------------------------------------------------------------
26515 !c! Elj
26516 !c! Lennard-Jones 6-12 interaction between heads
26517        pom = (pis / Rhead)**6.0d0
26518        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26519 !c! derivative of Elj is Glj
26520        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
26521            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26522 !c!-------------------------------------------------------------------
26523 !c! Return the results
26524 !c! These things do the dRdX derivatives, that is
26525 !c! allow us to change what we see from function that changes with
26526 !c! distance to function that changes with LOCATION (of the interaction
26527 !c! site)
26528        DO k = 1, 3
26529       erhead(k) = Rhead_distance(k)/Rhead
26530       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26531       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26532        END DO
26533
26534        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26535        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26536        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26537        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26538        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26539        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26540        facd1 = d1 * vbld_inv(i+nres)
26541        facd2 = d2 * vbld_inv(j+nres)
26542        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26543        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26544
26545 !c! Now we add appropriate partial derivatives (one in each dimension)
26546        DO k = 1, 3
26547       hawk   = (erhead_tail(k,1) + &
26548       facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
26549       condor = (erhead_tail(k,2) + &
26550       facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26551
26552       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26553       gvdwx(k,i) = gvdwx(k,i) &
26554               - dGCLdR * pom&
26555               - dGGBdR * pom&
26556               - dGCVdR * pom&
26557               - dPOLdR1 * hawk&
26558               - dPOLdR2 * (erhead_tail(k,2)&
26559       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26560               - dGLJdR * pom
26561
26562       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26563       gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom&
26564                + dGGBdR * pom+ dGCVdR * pom&
26565               + dPOLdR1 * (erhead_tail(k,1)&
26566       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))&
26567               + dPOLdR2 * condor + dGLJdR * pom
26568
26569       gvdwc(k,i) = gvdwc(k,i)  &
26570               - dGCLdR * erhead(k)&
26571               - dGGBdR * erhead(k)&
26572               - dGCVdR * erhead(k)&
26573               - dPOLdR1 * erhead_tail(k,1)&
26574               - dPOLdR2 * erhead_tail(k,2)&
26575               - dGLJdR * erhead(k)
26576
26577       gvdwc(k,j) = gvdwc(k,j)         &
26578               + dGCLdR * erhead(k) &
26579               + dGGBdR * erhead(k) &
26580               + dGCVdR * erhead(k) &
26581               + dPOLdR1 * erhead_tail(k,1) &
26582               + dPOLdR2 * erhead_tail(k,2)&
26583               + dGLJdR * erhead(k)
26584
26585        END DO
26586        RETURN
26587       END SUBROUTINE eqq
26588
26589       SUBROUTINE eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
26590       use calc_data
26591       use comm_momo
26592        real (kind=8) ::  facd3, facd4, federmaus, adler,&
26593        Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
26594 !       integer :: k
26595 !c! Epol and Gpol analytical parameters
26596        alphapol1 = alphapolcat(itypi,itypj)
26597        alphapol2 = alphapolcat(itypj,itypi)
26598 !c! Fisocav and Gisocav analytical parameters
26599        al1  = alphisocat(1,itypi,itypj)
26600        al2  = alphisocat(2,itypi,itypj)
26601        al3  = alphisocat(3,itypi,itypj)
26602        al4  = alphisocat(4,itypi,itypj)
26603        csig = (1.0d0  &
26604          / dsqrt(sigiso1cat(itypi, itypj)**2.0d0 &
26605          + sigiso2cat(itypi,itypj)**2.0d0))
26606 !c!
26607        pis  = sig0headcat(itypi,itypj)
26608        eps_head = epsheadcat(itypi,itypj)
26609        Rhead_sq = Rhead * Rhead
26610 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26611 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26612        R1 = 0.0d0
26613        R2 = 0.0d0
26614        DO k = 1, 3
26615 !c! Calculate head-to-tail distances needed by Epol
26616       R1=R1+(ctail(k,2)-chead(k,1))**2
26617       R2=R2+(chead(k,2)-ctail(k,1))**2
26618        END DO
26619 !c! Pitagoras
26620        R1 = dsqrt(R1)
26621        R2 = dsqrt(R2)
26622
26623 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26624 !c!     &        +dhead(1,1,itypi,itypj))**2))
26625 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26626 !c!     &        +dhead(2,1,itypi,itypj))**2))
26627
26628 !c!-------------------------------------------------------------------
26629 !c! Coulomb electrostatic interaction
26630        Ecl = (332.0d0 * Qij) / Rhead
26631 !c! derivative of Ecl is Gcl...
26632        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
26633        dGCLdOM1 = 0.0d0
26634        dGCLdOM2 = 0.0d0
26635        dGCLdOM12 = 0.0d0
26636        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26637        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26638        debkap=debaykapcat(itypi,itypj)
26639        Egb = -(332.0d0 * Qij *&
26640       (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
26641 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
26642 !c! Derivative of Egb is Ggb...
26643        dGGBdFGB = -(-332.0d0 * Qij * &
26644        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
26645        -(332.0d0 * Qij *&
26646       (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
26647        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
26648        dGGBdR = dGGBdFGB * dFGBdR
26649 !c!-------------------------------------------------------------------
26650 !c! Fisocav - isotropic cavity creation term
26651 !c! or "how much energy it costs to put charged head in water"
26652        pom = Rhead * csig
26653        top = al1 * (dsqrt(pom) + al2 * pom - al3)
26654        bot = (1.0d0 + al4 * pom**12.0d0)
26655        botsq = bot * bot
26656        FisoCav = top / bot
26657 !      write (*,*) "Rhead = ",Rhead
26658 !      write (*,*) "csig = ",csig
26659 !      write (*,*) "pom = ",pom
26660 !      write (*,*) "al1 = ",al1
26661 !      write (*,*) "al2 = ",al2
26662 !      write (*,*) "al3 = ",al3
26663 !      write (*,*) "al4 = ",al4
26664 !        write (*,*) "top = ",top
26665 !        write (*,*) "bot = ",bot
26666 !c! Derivative of Fisocav is GCV...
26667        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26668        dbot = 12.0d0 * al4 * pom ** 11.0d0
26669        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26670 !c!-------------------------------------------------------------------
26671 !c! Epol
26672 !c! Polarization energy - charged heads polarize hydrophobic "neck"
26673        MomoFac1 = (1.0d0 - chi1 * sqom2)
26674        MomoFac2 = (1.0d0 - chi2 * sqom1)
26675        RR1  = ( R1 * R1 ) / MomoFac1
26676        RR2  = ( R2 * R2 ) / MomoFac2
26677        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26678        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26679        fgb1 = sqrt( RR1 + a12sq * ee1 )
26680        fgb2 = sqrt( RR2 + a12sq * ee2 )
26681        epol = 332.0d0 * eps_inout_fac * ( &
26682       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26683 !c!       epol = 0.0d0
26684        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26685              / (fgb1 ** 5.0d0)
26686        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26687              / (fgb2 ** 5.0d0)
26688        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
26689            / ( 2.0d0 * fgb1 )
26690        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
26691            / ( 2.0d0 * fgb2 )
26692        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
26693             * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
26694        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
26695             * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
26696        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26697 !c!       dPOLdR1 = 0.0d0
26698        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26699 !c!       dPOLdR2 = 0.0d0
26700        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26701 !c!       dPOLdOM1 = 0.0d0
26702        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26703 !c!       dPOLdOM2 = 0.0d0
26704 !c!-------------------------------------------------------------------
26705 !c! Elj
26706 !c! Lennard-Jones 6-12 interaction between heads
26707        pom = (pis / Rhead)**6.0d0
26708        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26709 !c! derivative of Elj is Glj
26710        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
26711            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26712 !c!-------------------------------------------------------------------
26713 !c! Return the results
26714 !c! These things do the dRdX derivatives, that is
26715 !c! allow us to change what we see from function that changes with
26716 !c! distance to function that changes with LOCATION (of the interaction
26717 !c! site)
26718        DO k = 1, 3
26719       erhead(k) = Rhead_distance(k)/Rhead
26720       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26721       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26722        END DO
26723
26724        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26725        erdxj = scalar( erhead(1), dC_norm(1,j) )
26726        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26727        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
26728        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
26729        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26730        facd1 = d1 * vbld_inv(i+nres)
26731        facd2 = d2 * vbld_inv(j)
26732        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
26733        facd4 = dtailcat(2,itypi,itypj) * vbld_inv(j)
26734
26735 !c! Now we add appropriate partial derivatives (one in each dimension)
26736        DO k = 1, 3
26737       hawk   = (erhead_tail(k,1) + &
26738       facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
26739       condor = (erhead_tail(k,2) + &
26740       facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
26741
26742       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26743       gradpepcatx(k,i) = gradpepcatx(k,i) &
26744               - dGCLdR * pom&
26745               - dGGBdR * pom&
26746               - dGCVdR * pom&
26747               - dPOLdR1 * hawk&
26748               - dPOLdR2 * (erhead_tail(k,2)&
26749       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26750               - dGLJdR * pom
26751
26752       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
26753 !        gradpepcatx(k,j) = gradpepcatx(k,j)+ dGCLdR * pom&
26754 !                   + dGGBdR * pom+ dGCVdR * pom&
26755 !                  + dPOLdR1 * (erhead_tail(k,1)&
26756 !      -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j)))&
26757 !                  + dPOLdR2 * condor + dGLJdR * pom
26758
26759       gradpepcat(k,i) = gradpepcat(k,i)  &
26760               - dGCLdR * erhead(k)&
26761               - dGGBdR * erhead(k)&
26762               - dGCVdR * erhead(k)&
26763               - dPOLdR1 * erhead_tail(k,1)&
26764               - dPOLdR2 * erhead_tail(k,2)&
26765               - dGLJdR * erhead(k)
26766
26767       gradpepcat(k,j) = gradpepcat(k,j)         &
26768               + dGCLdR * erhead(k) &
26769               + dGGBdR * erhead(k) &
26770               + dGCVdR * erhead(k) &
26771               + dPOLdR1 * erhead_tail(k,1) &
26772               + dPOLdR2 * erhead_tail(k,2)&
26773               + dGLJdR * erhead(k)
26774
26775        END DO
26776        RETURN
26777       END SUBROUTINE eqq_cat
26778 !c!-------------------------------------------------------------------
26779       SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
26780       use comm_momo
26781       use calc_data
26782
26783        double precision eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad
26784        double precision ener(4)
26785        double precision dcosom1(3),dcosom2(3)
26786 !c! used in Epol derivatives
26787        double precision facd3, facd4
26788        double precision federmaus, adler
26789        integer istate,ii,jj
26790        real (kind=8) :: Fgb
26791 !       print *,"CALLING EQUAD"
26792 !c! Epol and Gpol analytical parameters
26793        alphapol1 = alphapol(itypi,itypj)
26794        alphapol2 = alphapol(itypj,itypi)
26795 !c! Fisocav and Gisocav analytical parameters
26796        al1  = alphiso(1,itypi,itypj)
26797        al2  = alphiso(2,itypi,itypj)
26798        al3  = alphiso(3,itypi,itypj)
26799        al4  = alphiso(4,itypi,itypj)
26800        csig = (1.0d0 / dsqrt(sigiso1(itypi, itypj)**2.0d0&
26801           + sigiso2(itypi,itypj)**2.0d0))
26802 !c!
26803        w1   = wqdip(1,itypi,itypj)
26804        w2   = wqdip(2,itypi,itypj)
26805        pis  = sig0head(itypi,itypj)
26806        eps_head = epshead(itypi,itypj)
26807 !c! First things first:
26808 !c! We need to do sc_grad's job with GB and Fcav
26809        eom1  = eps2der * eps2rt_om1 &
26810            - 2.0D0 * alf1 * eps3der&
26811            + sigder * sigsq_om1&
26812            + dCAVdOM1
26813        eom2  = eps2der * eps2rt_om2 &
26814            + 2.0D0 * alf2 * eps3der&
26815            + sigder * sigsq_om2&
26816            + dCAVdOM2
26817        eom12 =  evdwij  * eps1_om12 &
26818            + eps2der * eps2rt_om12 &
26819            - 2.0D0 * alf12 * eps3der&
26820            + sigder *sigsq_om12&
26821            + dCAVdOM12
26822 !c! now some magical transformations to project gradient into
26823 !c! three cartesian vectors
26824        DO k = 1, 3
26825       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
26826       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
26827       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
26828 !c! this acts on hydrophobic center of interaction
26829       gvdwx(k,i)= gvdwx(k,i) - gg(k) &
26830               + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
26831               + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26832       gvdwx(k,j)= gvdwx(k,j) + gg(k) &
26833               + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))&
26834               + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26835 !c! this acts on Calpha
26836       gvdwc(k,i)=gvdwc(k,i)-gg(k)
26837       gvdwc(k,j)=gvdwc(k,j)+gg(k)
26838        END DO
26839 !c! sc_grad is done, now we will compute
26840        eheadtail = 0.0d0
26841        eom1 = 0.0d0
26842        eom2 = 0.0d0
26843        eom12 = 0.0d0
26844        DO istate = 1, nstate(itypi,itypj)
26845 !c*************************************************************
26846       IF (istate.ne.1) THEN
26847        IF (istate.lt.3) THEN
26848         ii = 1
26849        ELSE
26850         ii = 2
26851        END IF
26852       jj = istate/ii
26853       d1 = dhead(1,ii,itypi,itypj)
26854       d2 = dhead(2,jj,itypi,itypj)
26855       DO k = 1,3
26856        chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
26857        chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
26858        Rhead_distance(k) = chead(k,2) - chead(k,1)
26859       END DO
26860 !c! pitagoras (root of sum of squares)
26861       Rhead = dsqrt( &
26862              (Rhead_distance(1)*Rhead_distance(1))  &
26863            + (Rhead_distance(2)*Rhead_distance(2))  &
26864            + (Rhead_distance(3)*Rhead_distance(3)))
26865       END IF
26866       Rhead_sq = Rhead * Rhead
26867
26868 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26869 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26870       R1 = 0.0d0
26871       R2 = 0.0d0
26872       DO k = 1, 3
26873 !c! Calculate head-to-tail distances
26874        R1=R1+(ctail(k,2)-chead(k,1))**2
26875        R2=R2+(chead(k,2)-ctail(k,1))**2
26876       END DO
26877 !c! Pitagoras
26878       R1 = dsqrt(R1)
26879       R2 = dsqrt(R2)
26880       Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
26881 !c!        Ecl = 0.0d0
26882 !c!        write (*,*) "Ecl = ", Ecl
26883 !c! derivative of Ecl is Gcl...
26884       dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
26885 !c!        dGCLdR = 0.0d0
26886       dGCLdOM1 = 0.0d0
26887       dGCLdOM2 = 0.0d0
26888       dGCLdOM12 = 0.0d0
26889 !c!-------------------------------------------------------------------
26890 !c! Generalised Born Solvent Polarization
26891       ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26892       Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26893       Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
26894 !c!        Egb = 0.0d0
26895 !c!      write (*,*) "a1*a2 = ", a12sq
26896 !c!      write (*,*) "Rhead = ", Rhead
26897 !c!      write (*,*) "Rhead_sq = ", Rhead_sq
26898 !c!      write (*,*) "ee = ", ee
26899 !c!      write (*,*) "Fgb = ", Fgb
26900 !c!      write (*,*) "fac = ", eps_inout_fac
26901 !c!      write (*,*) "Qij = ", Qij
26902 !c!      write (*,*) "Egb = ", Egb
26903 !c! Derivative of Egb is Ggb...
26904 !c! dFGBdR is used by Quad's later...
26905       dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
26906       dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )&
26907              / ( 2.0d0 * Fgb )
26908       dGGBdR = dGGBdFGB * dFGBdR
26909 !c!        dGGBdR = 0.0d0
26910 !c!-------------------------------------------------------------------
26911 !c! Fisocav - isotropic cavity creation term
26912       pom = Rhead * csig
26913       top = al1 * (dsqrt(pom) + al2 * pom - al3)
26914       bot = (1.0d0 + al4 * pom**12.0d0)
26915       botsq = bot * bot
26916       FisoCav = top / bot
26917       dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26918       dbot = 12.0d0 * al4 * pom ** 11.0d0
26919       dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26920 !c!        dGCVdR = 0.0d0
26921 !c!-------------------------------------------------------------------
26922 !c! Polarization energy
26923 !c! Epol
26924       MomoFac1 = (1.0d0 - chi1 * sqom2)
26925       MomoFac2 = (1.0d0 - chi2 * sqom1)
26926       RR1  = ( R1 * R1 ) / MomoFac1
26927       RR2  = ( R2 * R2 ) / MomoFac2
26928       ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26929       ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26930       fgb1 = sqrt( RR1 + a12sq * ee1 )
26931       fgb2 = sqrt( RR2 + a12sq * ee2 )
26932       epol = 332.0d0 * eps_inout_fac * (&
26933       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26934 !c!        epol = 0.0d0
26935 !c! derivative of Epol is Gpol...
26936       dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26937               / (fgb1 ** 5.0d0)
26938       dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26939               / (fgb2 ** 5.0d0)
26940       dFGBdR1 = ( (R1 / MomoFac1) &
26941             * ( 2.0d0 - (0.5d0 * ee1) ) )&
26942             / ( 2.0d0 * fgb1 )
26943       dFGBdR2 = ( (R2 / MomoFac2) &
26944             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26945             / ( 2.0d0 * fgb2 )
26946       dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26947              * ( 2.0d0 - 0.5d0 * ee1) ) &
26948              / ( 2.0d0 * fgb1 )
26949       dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26950              * ( 2.0d0 - 0.5d0 * ee2) ) &
26951              / ( 2.0d0 * fgb2 )
26952       dPOLdR1 = dPOLdFGB1 * dFGBdR1
26953 !c!        dPOLdR1 = 0.0d0
26954       dPOLdR2 = dPOLdFGB2 * dFGBdR2
26955 !c!        dPOLdR2 = 0.0d0
26956       dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26957 !c!        dPOLdOM1 = 0.0d0
26958       dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26959       pom = (pis / Rhead)**6.0d0
26960       Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26961 !c!        Elj = 0.0d0
26962 !c! derivative of Elj is Glj
26963       dGLJdR = 4.0d0 * eps_head &
26964           * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26965           +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26966 !c!        dGLJdR = 0.0d0
26967 !c!-------------------------------------------------------------------
26968 !c! Equad
26969        IF (Wqd.ne.0.0d0) THEN
26970       Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) &
26971            - 37.5d0  * ( sqom1 + sqom2 ) &
26972            + 157.5d0 * ( sqom1 * sqom2 ) &
26973            - 45.0d0  * om1*om2*om12
26974       fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
26975       Equad = fac * Beta1
26976 !c!        Equad = 0.0d0
26977 !c! derivative of Equad...
26978       dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
26979 !c!        dQUADdR = 0.0d0
26980       dQUADdOM1 = fac* (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
26981 !c!        dQUADdOM1 = 0.0d0
26982       dQUADdOM2 = fac* (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
26983 !c!        dQUADdOM2 = 0.0d0
26984       dQUADdOM12 = fac * ( 6.0d0*om12 - 45.0d0*om1*om2 )
26985        ELSE
26986        Beta1 = 0.0d0
26987        Equad = 0.0d0
26988       END IF
26989 !c!-------------------------------------------------------------------
26990 !c! Return the results
26991 !c! Angular stuff
26992       eom1 = dPOLdOM1 + dQUADdOM1
26993       eom2 = dPOLdOM2 + dQUADdOM2
26994       eom12 = dQUADdOM12
26995 !c! now some magical transformations to project gradient into
26996 !c! three cartesian vectors
26997       DO k = 1, 3
26998        dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
26999        dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
27000        tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
27001       END DO
27002 !c! Radial stuff
27003       DO k = 1, 3
27004        erhead(k) = Rhead_distance(k)/Rhead
27005        erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
27006        erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27007       END DO
27008       erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27009       erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27010       bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
27011       federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
27012       eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
27013       adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27014       facd1 = d1 * vbld_inv(i+nres)
27015       facd2 = d2 * vbld_inv(j+nres)
27016       facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
27017       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
27018       DO k = 1, 3
27019        hawk   = erhead_tail(k,1) + &
27020        facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
27021        condor = erhead_tail(k,2) + &
27022        facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
27023
27024        pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27025 !c! this acts on hydrophobic center of interaction
27026        gheadtail(k,1,1) = gheadtail(k,1,1) &
27027                    - dGCLdR * pom &
27028                    - dGGBdR * pom &
27029                    - dGCVdR * pom &
27030                    - dPOLdR1 * hawk &
27031                    - dPOLdR2 * (erhead_tail(k,2) &
27032       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
27033                    - dGLJdR * pom &
27034                    - dQUADdR * pom&
27035                    - tuna(k) &
27036              + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
27037              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
27038
27039        pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27040 !c! this acts on hydrophobic center of interaction
27041        gheadtail(k,2,1) = gheadtail(k,2,1)  &
27042                    + dGCLdR * pom      &
27043                    + dGGBdR * pom      &
27044                    + dGCVdR * pom      &
27045                    + dPOLdR1 * (erhead_tail(k,1) &
27046       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
27047                    + dPOLdR2 * condor &
27048                    + dGLJdR * pom &
27049                    + dQUADdR * pom &
27050                    + tuna(k) &
27051              + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
27052              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
27053
27054 !c! this acts on Calpha
27055        gheadtail(k,3,1) = gheadtail(k,3,1)  &
27056                    - dGCLdR * erhead(k)&
27057                    - dGGBdR * erhead(k)&
27058                    - dGCVdR * erhead(k)&
27059                    - dPOLdR1 * erhead_tail(k,1)&
27060                    - dPOLdR2 * erhead_tail(k,2)&
27061                    - dGLJdR * erhead(k) &
27062                    - dQUADdR * erhead(k)&
27063                    - tuna(k)
27064 !c! this acts on Calpha
27065        gheadtail(k,4,1) = gheadtail(k,4,1)   &
27066                     + dGCLdR * erhead(k) &
27067                     + dGGBdR * erhead(k) &
27068                     + dGCVdR * erhead(k) &
27069                     + dPOLdR1 * erhead_tail(k,1) &
27070                     + dPOLdR2 * erhead_tail(k,2) &
27071                     + dGLJdR * erhead(k) &
27072                     + dQUADdR * erhead(k)&
27073                     + tuna(k)
27074       END DO
27075       ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
27076       eheadtail = eheadtail &
27077               + wstate(istate, itypi, itypj) &
27078               * dexp(-betaT * ener(istate))
27079 !c! foreach cartesian dimension
27080       DO k = 1, 3
27081 !c! foreach of two gvdwx and gvdwc
27082        DO l = 1, 4
27083         gheadtail(k,l,2) = gheadtail(k,l,2)  &
27084                      + wstate( istate, itypi, itypj ) &
27085                      * dexp(-betaT * ener(istate)) &
27086                      * gheadtail(k,l,1)
27087         gheadtail(k,l,1) = 0.0d0
27088        END DO
27089       END DO
27090        END DO
27091 !c! Here ended the gigantic DO istate = 1, 4, which starts
27092 !c! at the beggining of the subroutine
27093
27094        DO k = 1, 3
27095       DO l = 1, 4
27096        gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
27097       END DO
27098       gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
27099       gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
27100       gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
27101       gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
27102       DO l = 1, 4
27103        gheadtail(k,l,1) = 0.0d0
27104        gheadtail(k,l,2) = 0.0d0
27105       END DO
27106        END DO
27107        eheadtail = (-dlog(eheadtail)) / betaT
27108        dPOLdOM1 = 0.0d0
27109        dPOLdOM2 = 0.0d0
27110        dQUADdOM1 = 0.0d0
27111        dQUADdOM2 = 0.0d0
27112        dQUADdOM12 = 0.0d0
27113        RETURN
27114       END SUBROUTINE energy_quad
27115 !!-----------------------------------------------------------
27116       SUBROUTINE eqn(Epol)
27117       use comm_momo
27118       use calc_data
27119
27120       double precision  facd4, federmaus,epol
27121       alphapol1 = alphapol(itypi,itypj)
27122 !c! R1 - distance between head of ith side chain and tail of jth sidechain
27123        R1 = 0.0d0
27124        DO k = 1, 3
27125 !c! Calculate head-to-tail distances
27126       R1=R1+(ctail(k,2)-chead(k,1))**2
27127        END DO
27128 !c! Pitagoras
27129        R1 = dsqrt(R1)
27130
27131 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27132 !c!     &        +dhead(1,1,itypi,itypj))**2))
27133 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27134 !c!     &        +dhead(2,1,itypi,itypj))**2))
27135 !c--------------------------------------------------------------------
27136 !c Polarization energy
27137 !c Epol
27138        MomoFac1 = (1.0d0 - chi1 * sqom2)
27139        RR1  = R1 * R1 / MomoFac1
27140        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
27141        fgb1 = sqrt( RR1 + a12sq * ee1)
27142        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
27143        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
27144              / (fgb1 ** 5.0d0)
27145        dFGBdR1 = ( (R1 / MomoFac1) &
27146             * ( 2.0d0 - (0.5d0 * ee1) ) ) &
27147             / ( 2.0d0 * fgb1 )
27148        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
27149             * (2.0d0 - 0.5d0 * ee1) ) &
27150             / (2.0d0 * fgb1)
27151        dPOLdR1 = dPOLdFGB1 * dFGBdR1
27152 !c!       dPOLdR1 = 0.0d0
27153        dPOLdOM1 = 0.0d0
27154        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
27155        DO k = 1, 3
27156       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
27157        END DO
27158        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
27159        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
27160        facd1 = d1 * vbld_inv(i+nres)
27161        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
27162
27163        DO k = 1, 3
27164       hawk = (erhead_tail(k,1) + &
27165       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
27166
27167       gvdwx(k,i) = gvdwx(k,i) &
27168                - dPOLdR1 * hawk
27169       gvdwx(k,j) = gvdwx(k,j) &
27170                + dPOLdR1 * (erhead_tail(k,1) &
27171        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
27172
27173       gvdwc(k,i) = gvdwc(k,i)  - dPOLdR1 * erhead_tail(k,1)
27174       gvdwc(k,j) = gvdwc(k,j)  + dPOLdR1 * erhead_tail(k,1)
27175
27176        END DO
27177        RETURN
27178       END SUBROUTINE eqn
27179       SUBROUTINE enq(Epol)
27180       use calc_data
27181       use comm_momo
27182        double precision facd3, adler,epol
27183        alphapol2 = alphapol(itypj,itypi)
27184 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27185        R2 = 0.0d0
27186        DO k = 1, 3
27187 !c! Calculate head-to-tail distances
27188       R2=R2+(chead(k,2)-ctail(k,1))**2
27189        END DO
27190 !c! Pitagoras
27191        R2 = dsqrt(R2)
27192
27193 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27194 !c!     &        +dhead(1,1,itypi,itypj))**2))
27195 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27196 !c!     &        +dhead(2,1,itypi,itypj))**2))
27197 !c------------------------------------------------------------------------
27198 !c Polarization energy
27199        MomoFac2 = (1.0d0 - chi2 * sqom1)
27200        RR2  = R2 * R2 / MomoFac2
27201        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27202        fgb2 = sqrt(RR2  + a12sq * ee2)
27203        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27204        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27205             / (fgb2 ** 5.0d0)
27206        dFGBdR2 = ( (R2 / MomoFac2)  &
27207             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27208             / (2.0d0 * fgb2)
27209        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27210             * (2.0d0 - 0.5d0 * ee2) ) &
27211             / (2.0d0 * fgb2)
27212        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27213 !c!       dPOLdR2 = 0.0d0
27214        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27215 !c!       dPOLdOM1 = 0.0d0
27216        dPOLdOM2 = 0.0d0
27217 !c!-------------------------------------------------------------------
27218 !c! Return the results
27219 !c! (See comments in Eqq)
27220        DO k = 1, 3
27221       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27222        END DO
27223        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
27224        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27225        facd2 = d2 * vbld_inv(j+nres)
27226        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
27227        DO k = 1, 3
27228       condor = (erhead_tail(k,2) &
27229        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
27230
27231       gvdwx(k,i) = gvdwx(k,i) &
27232                - dPOLdR2 * (erhead_tail(k,2) &
27233        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
27234       gvdwx(k,j) = gvdwx(k,j)   &
27235                + dPOLdR2 * condor
27236
27237       gvdwc(k,i) = gvdwc(k,i) &
27238                - dPOLdR2 * erhead_tail(k,2)
27239       gvdwc(k,j) = gvdwc(k,j) &
27240                + dPOLdR2 * erhead_tail(k,2)
27241
27242        END DO
27243       RETURN
27244       END SUBROUTINE enq
27245
27246       SUBROUTINE enq_cat(Epol)
27247       use calc_data
27248       use comm_momo
27249        double precision facd3, adler,epol
27250        alphapol2 = alphapolcat(itypj,itypi)
27251 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27252        R2 = 0.0d0
27253        DO k = 1, 3
27254 !c! Calculate head-to-tail distances
27255       R2=R2+(chead(k,2)-ctail(k,1))**2
27256        END DO
27257 !c! Pitagoras
27258        R2 = dsqrt(R2)
27259
27260 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27261 !c!     &        +dhead(1,1,itypi,itypj))**2))
27262 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27263 !c!     &        +dhead(2,1,itypi,itypj))**2))
27264 !c------------------------------------------------------------------------
27265 !c Polarization energy
27266        MomoFac2 = (1.0d0 - chi2 * sqom1)
27267        RR2  = R2 * R2 / MomoFac2
27268        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27269        fgb2 = sqrt(RR2  + a12sq * ee2)
27270        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27271        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27272             / (fgb2 ** 5.0d0)
27273        dFGBdR2 = ( (R2 / MomoFac2)  &
27274             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27275             / (2.0d0 * fgb2)
27276        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27277             * (2.0d0 - 0.5d0 * ee2) ) &
27278             / (2.0d0 * fgb2)
27279        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27280 !c!       dPOLdR2 = 0.0d0
27281        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27282 !c!       dPOLdOM1 = 0.0d0
27283        dPOLdOM2 = 0.0d0
27284
27285 !c!-------------------------------------------------------------------
27286 !c! Return the results
27287 !c! (See comments in Eqq)
27288        DO k = 1, 3
27289       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27290        END DO
27291        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27292        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27293        facd2 = d2 * vbld_inv(j+nres)
27294        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
27295        DO k = 1, 3
27296       condor = (erhead_tail(k,2) &
27297        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27298
27299       gradpepcatx(k,i) = gradpepcatx(k,i) &
27300                - dPOLdR2 * (erhead_tail(k,2) &
27301        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
27302 !        gradpepcatx(k,j) = gradpepcatx(k,j)   &
27303 !                   + dPOLdR2 * condor
27304
27305       gradpepcat(k,i) = gradpepcat(k,i) &
27306                - dPOLdR2 * erhead_tail(k,2)
27307       gradpepcat(k,j) = gradpepcat(k,j) &
27308                + dPOLdR2 * erhead_tail(k,2)
27309
27310        END DO
27311       RETURN
27312       END SUBROUTINE enq_cat
27313
27314       SUBROUTINE eqd(Ecl,Elj,Epol)
27315       use calc_data
27316       use comm_momo
27317        double precision  facd4, federmaus,ecl,elj,epol
27318        alphapol1 = alphapol(itypi,itypj)
27319        w1        = wqdip(1,itypi,itypj)
27320        w2        = wqdip(2,itypi,itypj)
27321        pis       = sig0head(itypi,itypj)
27322        eps_head   = epshead(itypi,itypj)
27323 !c!-------------------------------------------------------------------
27324 !c! R1 - distance between head of ith side chain and tail of jth sidechain
27325        R1 = 0.0d0
27326        DO k = 1, 3
27327 !c! Calculate head-to-tail distances
27328       R1=R1+(ctail(k,2)-chead(k,1))**2
27329        END DO
27330 !c! Pitagoras
27331        R1 = dsqrt(R1)
27332
27333 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27334 !c!     &        +dhead(1,1,itypi,itypj))**2))
27335 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27336 !c!     &        +dhead(2,1,itypi,itypj))**2))
27337
27338 !c!-------------------------------------------------------------------
27339 !c! ecl
27340        sparrow  = w1 * Qi * om1
27341        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
27342        Ecl = sparrow / Rhead**2.0d0 &
27343          - hawk    / Rhead**4.0d0
27344        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27345              + 4.0d0 * hawk    / Rhead**5.0d0
27346 !c! dF/dom1
27347        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
27348 !c! dF/dom2
27349        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
27350 !c--------------------------------------------------------------------
27351 !c Polarization energy
27352 !c Epol
27353        MomoFac1 = (1.0d0 - chi1 * sqom2)
27354        RR1  = R1 * R1 / MomoFac1
27355        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
27356        fgb1 = sqrt( RR1 + a12sq * ee1)
27357        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
27358 !c!       epol = 0.0d0
27359 !c!------------------------------------------------------------------
27360 !c! derivative of Epol is Gpol...
27361        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
27362              / (fgb1 ** 5.0d0)
27363        dFGBdR1 = ( (R1 / MomoFac1)  &
27364            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
27365            / ( 2.0d0 * fgb1 )
27366        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
27367              * (2.0d0 - 0.5d0 * ee1) ) &
27368              / (2.0d0 * fgb1)
27369        dPOLdR1 = dPOLdFGB1 * dFGBdR1
27370 !c!       dPOLdR1 = 0.0d0
27371        dPOLdOM1 = 0.0d0
27372        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
27373 !c!       dPOLdOM2 = 0.0d0
27374 !c!-------------------------------------------------------------------
27375 !c! Elj
27376        pom = (pis / Rhead)**6.0d0
27377        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27378 !c! derivative of Elj is Glj
27379        dGLJdR = 4.0d0 * eps_head &
27380         * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27381         +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27382        DO k = 1, 3
27383       erhead(k) = Rhead_distance(k)/Rhead
27384       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
27385        END DO
27386
27387        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27388        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27389        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
27390        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
27391        facd1 = d1 * vbld_inv(i+nres)
27392        facd2 = d2 * vbld_inv(j+nres)
27393        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
27394
27395        DO k = 1, 3
27396       hawk = (erhead_tail(k,1) +  &
27397       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
27398
27399       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27400       gvdwx(k,i) = gvdwx(k,i)  &
27401                - dGCLdR * pom&
27402                - dPOLdR1 * hawk &
27403                - dGLJdR * pom
27404
27405       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27406       gvdwx(k,j) = gvdwx(k,j)    &
27407                + dGCLdR * pom  &
27408                + dPOLdR1 * (erhead_tail(k,1) &
27409        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
27410                + dGLJdR * pom
27411
27412
27413       gvdwc(k,i) = gvdwc(k,i)          &
27414                - dGCLdR * erhead(k)  &
27415                - dPOLdR1 * erhead_tail(k,1) &
27416                - dGLJdR * erhead(k)
27417
27418       gvdwc(k,j) = gvdwc(k,j)          &
27419                + dGCLdR * erhead(k)  &
27420                + dPOLdR1 * erhead_tail(k,1) &
27421                + dGLJdR * erhead(k)
27422
27423        END DO
27424        RETURN
27425       END SUBROUTINE eqd
27426       SUBROUTINE edq(Ecl,Elj,Epol)
27427 !       IMPLICIT NONE
27428        use comm_momo
27429       use calc_data
27430
27431       double precision  facd3, adler,ecl,elj,epol
27432        alphapol2 = alphapol(itypj,itypi)
27433        w1        = wqdip(1,itypi,itypj)
27434        w2        = wqdip(2,itypi,itypj)
27435        pis       = sig0head(itypi,itypj)
27436        eps_head  = epshead(itypi,itypj)
27437 !c!-------------------------------------------------------------------
27438 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27439        R2 = 0.0d0
27440        DO k = 1, 3
27441 !c! Calculate head-to-tail distances
27442       R2=R2+(chead(k,2)-ctail(k,1))**2
27443        END DO
27444 !c! Pitagoras
27445        R2 = dsqrt(R2)
27446
27447 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27448 !c!     &        +dhead(1,1,itypi,itypj))**2))
27449 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27450 !c!     &        +dhead(2,1,itypi,itypj))**2))
27451
27452
27453 !c!-------------------------------------------------------------------
27454 !c! ecl
27455        sparrow  = w1 * Qj * om1
27456        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
27457        ECL = sparrow / Rhead**2.0d0 &
27458          - hawk    / Rhead**4.0d0
27459 !c!-------------------------------------------------------------------
27460 !c! derivative of ecl is Gcl
27461 !c! dF/dr part
27462        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27463              + 4.0d0 * hawk    / Rhead**5.0d0
27464 !c! dF/dom1
27465        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
27466 !c! dF/dom2
27467        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
27468 !c--------------------------------------------------------------------
27469 !c Polarization energy
27470 !c Epol
27471        MomoFac2 = (1.0d0 - chi2 * sqom1)
27472        RR2  = R2 * R2 / MomoFac2
27473        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27474        fgb2 = sqrt(RR2  + a12sq * ee2)
27475        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27476        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27477              / (fgb2 ** 5.0d0)
27478        dFGBdR2 = ( (R2 / MomoFac2)  &
27479              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27480              / (2.0d0 * fgb2)
27481        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27482             * (2.0d0 - 0.5d0 * ee2) ) &
27483             / (2.0d0 * fgb2)
27484        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27485 !c!       dPOLdR2 = 0.0d0
27486        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27487 !c!       dPOLdOM1 = 0.0d0
27488        dPOLdOM2 = 0.0d0
27489 !c!-------------------------------------------------------------------
27490 !c! Elj
27491        pom = (pis / Rhead)**6.0d0
27492        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27493 !c! derivative of Elj is Glj
27494        dGLJdR = 4.0d0 * eps_head &
27495          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27496          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27497 !c!-------------------------------------------------------------------
27498 !c! Return the results
27499 !c! (see comments in Eqq)
27500        DO k = 1, 3
27501       erhead(k) = Rhead_distance(k)/Rhead
27502       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27503        END DO
27504        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27505        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27506        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
27507        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27508        facd1 = d1 * vbld_inv(i+nres)
27509        facd2 = d2 * vbld_inv(j+nres)
27510        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
27511        DO k = 1, 3
27512       condor = (erhead_tail(k,2) &
27513        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
27514
27515       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27516       gvdwx(k,i) = gvdwx(k,i) &
27517               - dGCLdR * pom &
27518               - dPOLdR2 * (erhead_tail(k,2) &
27519        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27520               - dGLJdR * pom
27521
27522       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27523       gvdwx(k,j) = gvdwx(k,j) &
27524               + dGCLdR * pom &
27525               + dPOLdR2 * condor &
27526               + dGLJdR * pom
27527
27528
27529       gvdwc(k,i) = gvdwc(k,i) &
27530               - dGCLdR * erhead(k) &
27531               - dPOLdR2 * erhead_tail(k,2) &
27532               - dGLJdR * erhead(k)
27533
27534       gvdwc(k,j) = gvdwc(k,j) &
27535               + dGCLdR * erhead(k) &
27536               + dPOLdR2 * erhead_tail(k,2) &
27537               + dGLJdR * erhead(k)
27538
27539        END DO
27540        RETURN
27541       END SUBROUTINE edq
27542
27543       SUBROUTINE edq_cat(Ecl,Elj,Epol)
27544       use comm_momo
27545       use calc_data
27546
27547       double precision  facd3, adler,ecl,elj,epol
27548        alphapol2 = alphapolcat(itypj,itypi)
27549        w1        = wqdipcat(1,itypi,itypj)
27550        w2        = wqdipcat(2,itypi,itypj)
27551        pis       = sig0headcat(itypi,itypj)
27552        eps_head  = epsheadcat(itypi,itypj)
27553 !c!-------------------------------------------------------------------
27554 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27555        R2 = 0.0d0
27556        DO k = 1, 3
27557 !c! Calculate head-to-tail distances
27558       R2=R2+(chead(k,2)-ctail(k,1))**2
27559        END DO
27560 !c! Pitagoras
27561        R2 = dsqrt(R2)
27562
27563 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27564 !c!     &        +dhead(1,1,itypi,itypj))**2))
27565 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27566 !c!     &        +dhead(2,1,itypi,itypj))**2))
27567
27568
27569 !c!-------------------------------------------------------------------
27570 !c! ecl
27571 !       write(iout,*) "KURWA2",Rhead
27572        sparrow  = w1 * Qj * om1
27573        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
27574        ECL = sparrow / Rhead**2.0d0 &
27575          - hawk    / Rhead**4.0d0
27576 !c!-------------------------------------------------------------------
27577 !c! derivative of ecl is Gcl
27578 !c! dF/dr part
27579        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27580              + 4.0d0 * hawk    / Rhead**5.0d0
27581 !c! dF/dom1
27582        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
27583 !c! dF/dom2
27584        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
27585 !c--------------------------------------------------------------------
27586 !c--------------------------------------------------------------------
27587 !c Polarization energy
27588 !c Epol
27589        MomoFac2 = (1.0d0 - chi2 * sqom1)
27590        RR2  = R2 * R2 / MomoFac2
27591        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27592        fgb2 = sqrt(RR2  + a12sq * ee2)
27593        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27594        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27595              / (fgb2 ** 5.0d0)
27596        dFGBdR2 = ( (R2 / MomoFac2)  &
27597              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27598              / (2.0d0 * fgb2)
27599        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27600             * (2.0d0 - 0.5d0 * ee2) ) &
27601             / (2.0d0 * fgb2)
27602        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27603 !c!       dPOLdR2 = 0.0d0
27604        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27605 !c!       dPOLdOM1 = 0.0d0
27606        dPOLdOM2 = 0.0d0
27607 !c!-------------------------------------------------------------------
27608 !c! Elj
27609        pom = (pis / Rhead)**6.0d0
27610        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27611 !c! derivative of Elj is Glj
27612        dGLJdR = 4.0d0 * eps_head &
27613          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27614          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27615 !c!-------------------------------------------------------------------
27616
27617 !c! Return the results
27618 !c! (see comments in Eqq)
27619        DO k = 1, 3
27620       erhead(k) = Rhead_distance(k)/Rhead
27621       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27622        END DO
27623        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27624        erdxj = scalar( erhead(1), dC_norm(1,j) )
27625        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27626        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27627        facd1 = d1 * vbld_inv(i+nres)
27628        facd2 = d2 * vbld_inv(j)
27629        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
27630        DO k = 1, 3
27631       condor = (erhead_tail(k,2) &
27632        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27633
27634       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27635       gradpepcatx(k,i) = gradpepcatx(k,i) &
27636               - dGCLdR * pom &
27637               - dPOLdR2 * (erhead_tail(k,2) &
27638        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27639               - dGLJdR * pom
27640
27641       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
27642 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
27643 !                  + dGCLdR * pom &
27644 !                  + dPOLdR2 * condor &
27645 !                  + dGLJdR * pom
27646
27647
27648       gradpepcat(k,i) = gradpepcat(k,i) &
27649               - dGCLdR * erhead(k) &
27650               - dPOLdR2 * erhead_tail(k,2) &
27651               - dGLJdR * erhead(k)
27652
27653       gradpepcat(k,j) = gradpepcat(k,j) &
27654               + dGCLdR * erhead(k) &
27655               + dPOLdR2 * erhead_tail(k,2) &
27656               + dGLJdR * erhead(k)
27657
27658        END DO
27659        RETURN
27660       END SUBROUTINE edq_cat
27661
27662       SUBROUTINE edq_cat_pep(Ecl,Elj,Epol)
27663       use comm_momo
27664       use calc_data
27665
27666       double precision  facd3, adler,ecl,elj,epol
27667        alphapol2 = alphapolcat(itypj,itypi)
27668        w1        = wqdipcat(1,itypi,itypj)
27669        w2        = wqdipcat(2,itypi,itypj)
27670        pis       = sig0headcat(itypi,itypj)
27671        eps_head  = epsheadcat(itypi,itypj)
27672 !c!-------------------------------------------------------------------
27673 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27674        R2 = 0.0d0
27675        DO k = 1, 3
27676 !c! Calculate head-to-tail distances
27677       R2=R2+(chead(k,2)-ctail(k,1))**2
27678        END DO
27679 !c! Pitagoras
27680        R2 = dsqrt(R2)
27681
27682 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27683 !c!     &        +dhead(1,1,itypi,itypj))**2))
27684 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27685 !c!     &        +dhead(2,1,itypi,itypj))**2))
27686
27687
27688 !c!-------------------------------------------------------------------
27689 !c! ecl
27690        sparrow  = w1 * Qj * om1
27691        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
27692 !       print *,"CO2", itypi,itypj
27693 !       print *,"CO?!.", w1,w2,Qj,om1
27694        ECL = sparrow / Rhead**2.0d0 &
27695          - hawk    / Rhead**4.0d0
27696 !c!-------------------------------------------------------------------
27697 !c! derivative of ecl is Gcl
27698 !c! dF/dr part
27699        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27700              + 4.0d0 * hawk    / Rhead**5.0d0
27701 !c! dF/dom1
27702        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
27703 !c! dF/dom2
27704        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
27705 !c--------------------------------------------------------------------
27706 !c--------------------------------------------------------------------
27707 !c Polarization energy
27708 !c Epol
27709        MomoFac2 = (1.0d0 - chi2 * sqom1)
27710        RR2  = R2 * R2 / MomoFac2
27711        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27712        fgb2 = sqrt(RR2  + a12sq * ee2)
27713        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27714        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27715              / (fgb2 ** 5.0d0)
27716        dFGBdR2 = ( (R2 / MomoFac2)  &
27717              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27718              / (2.0d0 * fgb2)
27719        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27720             * (2.0d0 - 0.5d0 * ee2) ) &
27721             / (2.0d0 * fgb2)
27722        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27723 !c!       dPOLdR2 = 0.0d0
27724        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27725 !c!       dPOLdOM1 = 0.0d0
27726        dPOLdOM2 = 0.0d0
27727 !c!-------------------------------------------------------------------
27728 !c! Elj
27729        pom = (pis / Rhead)**6.0d0
27730        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27731 !c! derivative of Elj is Glj
27732        dGLJdR = 4.0d0 * eps_head &
27733          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27734          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27735 !c!-------------------------------------------------------------------
27736
27737 !c! Return the results
27738 !c! (see comments in Eqq)
27739        DO k = 1, 3
27740       erhead(k) = Rhead_distance(k)/Rhead
27741       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27742        END DO
27743        erdxi = scalar( erhead(1), dC_norm(1,i) )
27744        erdxj = scalar( erhead(1), dC_norm(1,j) )
27745        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27746        adler = scalar( erhead_tail(1,2), dC_norm(1,i) )
27747        facd1 = d1 * vbld_inv(i+1)/2.0
27748        facd2 = d2 * vbld_inv(j)
27749        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+1)/2.0
27750        DO k = 1, 3
27751       condor = (erhead_tail(k,2) &
27752        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27753
27754       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i))
27755 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
27756 !                  - dGCLdR * pom &
27757 !                  - dPOLdR2 * (erhead_tail(k,2) &
27758 !       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27759 !                  - dGLJdR * pom
27760
27761       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
27762 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
27763 !                  + dGCLdR * pom &
27764 !                  + dPOLdR2 * condor &
27765 !                  + dGLJdR * pom
27766
27767
27768       gradpepcat(k,i) = gradpepcat(k,i) +0.5d0*( &
27769               - dGCLdR * erhead(k) &
27770               - dPOLdR2 * erhead_tail(k,2) &
27771               - dGLJdR * erhead(k))
27772       gradpepcat(k,i+1) = gradpepcat(k,i+1) +0.5d0*( &
27773               - dGCLdR * erhead(k) &
27774               - dPOLdR2 * erhead_tail(k,2) &
27775               - dGLJdR * erhead(k))
27776
27777
27778       gradpepcat(k,j) = gradpepcat(k,j) &
27779               + dGCLdR * erhead(k) &
27780               + dPOLdR2 * erhead_tail(k,2) &
27781               + dGLJdR * erhead(k)
27782
27783        END DO
27784        RETURN
27785       END SUBROUTINE edq_cat_pep
27786
27787       SUBROUTINE edd(ECL)
27788 !       IMPLICIT NONE
27789        use comm_momo
27790       use calc_data
27791
27792        double precision ecl
27793 !c!       csig = sigiso(itypi,itypj)
27794        w1 = wqdip(1,itypi,itypj)
27795        w2 = wqdip(2,itypi,itypj)
27796 !c!-------------------------------------------------------------------
27797 !c! ECL
27798        fac = (om12 - 3.0d0 * om1 * om2)
27799        c1 = (w1 / (Rhead**3.0d0)) * fac
27800        c2 = (w2 / Rhead ** 6.0d0) &
27801         * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
27802        ECL = c1 - c2
27803 !c!       write (*,*) "w1 = ", w1
27804 !c!       write (*,*) "w2 = ", w2
27805 !c!       write (*,*) "om1 = ", om1
27806 !c!       write (*,*) "om2 = ", om2
27807 !c!       write (*,*) "om12 = ", om12
27808 !c!       write (*,*) "fac = ", fac
27809 !c!       write (*,*) "c1 = ", c1
27810 !c!       write (*,*) "c2 = ", c2
27811 !c!       write (*,*) "Ecl = ", Ecl
27812 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
27813 !c!       write (*,*) "c2_2 = ",
27814 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
27815 !c!-------------------------------------------------------------------
27816 !c! dervative of ECL is GCL...
27817 !c! dECL/dr
27818        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
27819        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
27820         * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
27821        dGCLdR = c1 - c2
27822 !c! dECL/dom1
27823        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
27824        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
27825         * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
27826        dGCLdOM1 = c1 - c2
27827 !c! dECL/dom2
27828        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
27829        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
27830         * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
27831        dGCLdOM2 = c1 - c2
27832 !c! dECL/dom12
27833        c1 = w1 / (Rhead ** 3.0d0)
27834        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
27835        dGCLdOM12 = c1 - c2
27836 !c!-------------------------------------------------------------------
27837 !c! Return the results
27838 !c! (see comments in Eqq)
27839        DO k= 1, 3
27840       erhead(k) = Rhead_distance(k)/Rhead
27841        END DO
27842        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27843        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27844        facd1 = d1 * vbld_inv(i+nres)
27845        facd2 = d2 * vbld_inv(j+nres)
27846        DO k = 1, 3
27847
27848       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27849       gvdwx(k,i) = gvdwx(k,i)    - dGCLdR * pom
27850       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27851       gvdwx(k,j) = gvdwx(k,j)    + dGCLdR * pom
27852
27853       gvdwc(k,i) = gvdwc(k,i)    - dGCLdR * erhead(k)
27854       gvdwc(k,j) = gvdwc(k,j)    + dGCLdR * erhead(k)
27855        END DO
27856        RETURN
27857       END SUBROUTINE edd
27858       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27859 !       IMPLICIT NONE
27860        use comm_momo
27861       use calc_data
27862
27863        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
27864        eps_out=80.0d0
27865        itypi = itype(i,1)
27866        itypj = itype(j,1)
27867 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
27868 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
27869 !c!       t_bath = 300
27870 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
27871        Rb=0.001986d0
27872        BetaT = 1.0d0 / (298.0d0 * Rb)
27873 !c! Gay-berne var's
27874        sig0ij = sigma( itypi,itypj )
27875        chi1   = chi( itypi, itypj )
27876        chi2   = chi( itypj, itypi )
27877        chi12  = chi1 * chi2
27878        chip1  = chipp( itypi, itypj )
27879        chip2  = chipp( itypj, itypi )
27880        chip12 = chip1 * chip2
27881 !       chi1=0.0
27882 !       chi2=0.0
27883 !       chi12=0.0
27884 !       chip1=0.0
27885 !       chip2=0.0
27886 !       chip12=0.0
27887 !c! not used by momo potential, but needed by sc_angular which is shared
27888 !c! by all energy_potential subroutines
27889        alf1   = 0.0d0
27890        alf2   = 0.0d0
27891        alf12  = 0.0d0
27892 !c! location, location, location
27893 !       xj  = c( 1, nres+j ) - xi
27894 !       yj  = c( 2, nres+j ) - yi
27895 !       zj  = c( 3, nres+j ) - zi
27896        dxj = dc_norm( 1, nres+j )
27897        dyj = dc_norm( 2, nres+j )
27898        dzj = dc_norm( 3, nres+j )
27899 !c! distance from center of chain(?) to polar/charged head
27900 !c!       write (*,*) "istate = ", 1
27901 !c!       write (*,*) "ii = ", 1
27902 !c!       write (*,*) "jj = ", 1
27903        d1 = dhead(1, 1, itypi, itypj)
27904        d2 = dhead(2, 1, itypi, itypj)
27905 !c! ai*aj from Fgb
27906        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
27907 !c!       a12sq = a12sq * a12sq
27908 !c! charge of amino acid itypi is...
27909        Qi  = icharge(itypi)
27910        Qj  = icharge(itypj)
27911        Qij = Qi * Qj
27912 !c! chis1,2,12
27913        chis1 = chis(itypi,itypj)
27914        chis2 = chis(itypj,itypi)
27915        chis12 = chis1 * chis2
27916        sig1 = sigmap1(itypi,itypj)
27917        sig2 = sigmap2(itypi,itypj)
27918 !c!       write (*,*) "sig1 = ", sig1
27919 !c!       write (*,*) "sig2 = ", sig2
27920 !c! alpha factors from Fcav/Gcav
27921        b1cav = alphasur(1,itypi,itypj)
27922 !       b1cav=0.0
27923        b2cav = alphasur(2,itypi,itypj)
27924        b3cav = alphasur(3,itypi,itypj)
27925        b4cav = alphasur(4,itypi,itypj)
27926        wqd = wquad(itypi, itypj)
27927 !c! used by Fgb
27928        eps_in = epsintab(itypi,itypj)
27929        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
27930 !c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
27931 !c!-------------------------------------------------------------------
27932 !c! tail location and distance calculations
27933        Rtail = 0.0d0
27934        DO k = 1, 3
27935       ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
27936       ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
27937        END DO
27938 !c! tail distances will be themselves usefull elswhere
27939 !c1 (in Gcav, for example)
27940        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
27941        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
27942        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
27943        Rtail = dsqrt(  &
27944         (Rtail_distance(1)*Rtail_distance(1))  &
27945       + (Rtail_distance(2)*Rtail_distance(2))  &
27946       + (Rtail_distance(3)*Rtail_distance(3)))
27947 !c!-------------------------------------------------------------------
27948 !c! Calculate location and distance between polar heads
27949 !c! distance between heads
27950 !c! for each one of our three dimensional space...
27951        d1 = dhead(1, 1, itypi, itypj)
27952        d2 = dhead(2, 1, itypi, itypj)
27953
27954        DO k = 1,3
27955 !c! location of polar head is computed by taking hydrophobic centre
27956 !c! and moving by a d1 * dc_norm vector
27957 !c! see unres publications for very informative images
27958       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27959       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
27960 !c! distance
27961 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27962 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27963       Rhead_distance(k) = chead(k,2) - chead(k,1)
27964        END DO
27965 !c! pitagoras (root of sum of squares)
27966        Rhead = dsqrt(   &
27967         (Rhead_distance(1)*Rhead_distance(1)) &
27968       + (Rhead_distance(2)*Rhead_distance(2)) &
27969       + (Rhead_distance(3)*Rhead_distance(3)))
27970 !c!-------------------------------------------------------------------
27971 !c! zero everything that should be zero'ed
27972        Egb = 0.0d0
27973        ECL = 0.0d0
27974        Elj = 0.0d0
27975        Equad = 0.0d0
27976        Epol = 0.0d0
27977        eheadtail = 0.0d0
27978        dGCLdOM1 = 0.0d0
27979        dGCLdOM2 = 0.0d0
27980        dGCLdOM12 = 0.0d0
27981        dPOLdOM1 = 0.0d0
27982        dPOLdOM2 = 0.0d0
27983        RETURN
27984       END SUBROUTINE elgrad_init
27985
27986
27987       SUBROUTINE elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27988       use comm_momo
27989       use calc_data
27990        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
27991        eps_out=80.0d0
27992        itypi = itype(i,1)
27993        itypj = itype(j,5)
27994 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
27995 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
27996 !c!       t_bath = 300
27997 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
27998        Rb=0.001986d0
27999        BetaT = 1.0d0 / (298.0d0 * Rb)
28000 !c! Gay-berne var's
28001        sig0ij = sigmacat( itypi,itypj )
28002        chi1   = chi1cat( itypi, itypj )
28003        chi2   = 0.0d0
28004        chi12  = 0.0d0
28005        chip1  = chipp1cat( itypi, itypj )
28006        chip2  = 0.0d0
28007        chip12 = 0.0d0
28008 !c! not used by momo potential, but needed by sc_angular which is shared
28009 !c! by all energy_potential subroutines
28010        alf1   = 0.0d0
28011        alf2   = 0.0d0
28012        alf12  = 0.0d0
28013        dxj = dc_norm( 1, nres+j )
28014        dyj = dc_norm( 2, nres+j )
28015        dzj = dc_norm( 3, nres+j )
28016 !c! distance from center of chain(?) to polar/charged head
28017        d1 = dheadcat(1, 1, itypi, itypj)
28018        d2 = dheadcat(2, 1, itypi, itypj)
28019 !c! ai*aj from Fgb
28020        a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj)
28021 !c!       a12sq = a12sq * a12sq
28022 !c! charge of amino acid itypi is...
28023        Qi  = icharge(itypi)
28024        Qj  = ichargecat(itypj)
28025        Qij = Qi * Qj
28026 !c! chis1,2,12
28027        chis1 = chis1cat(itypi,itypj)
28028        chis2 = 0.0d0
28029        chis12 = 0.0d0
28030        sig1 = sigmap1cat(itypi,itypj)
28031        sig2 = sigmap2cat(itypi,itypj)
28032 !c! alpha factors from Fcav/Gcav
28033        b1cav = alphasurcat(1,itypi,itypj)
28034        b2cav = alphasurcat(2,itypi,itypj)
28035        b3cav = alphasurcat(3,itypi,itypj)
28036        b4cav = alphasurcat(4,itypi,itypj)
28037        wqd = wquadcat(itypi, itypj)
28038 !c! used by Fgb
28039        eps_in = epsintabcat(itypi,itypj)
28040        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
28041 !c!-------------------------------------------------------------------
28042 !c! tail location and distance calculations
28043        Rtail = 0.0d0
28044        DO k = 1, 3
28045       ctail(k,1)=c(k,i+nres)-dtailcat(1,itypi,itypj)*dc_norm(k,nres+i)
28046       ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
28047        END DO
28048 !c! tail distances will be themselves usefull elswhere
28049 !c1 (in Gcav, for example)
28050        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
28051        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
28052        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
28053        Rtail = dsqrt(  &
28054         (Rtail_distance(1)*Rtail_distance(1))  &
28055       + (Rtail_distance(2)*Rtail_distance(2))  &
28056       + (Rtail_distance(3)*Rtail_distance(3)))
28057 !c!-------------------------------------------------------------------
28058 !c! Calculate location and distance between polar heads
28059 !c! distance between heads
28060 !c! for each one of our three dimensional space...
28061        d1 = dheadcat(1, 1, itypi, itypj)
28062        d2 = dheadcat(2, 1, itypi, itypj)
28063
28064        DO k = 1,3
28065 !c! location of polar head is computed by taking hydrophobic centre
28066 !c! and moving by a d1 * dc_norm vector
28067 !c! see unres publications for very informative images
28068       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
28069       chead(k,2) = c(k, j)
28070 !c! distance
28071 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
28072 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
28073       Rhead_distance(k) = chead(k,2) - chead(k,1)
28074        END DO
28075 !c! pitagoras (root of sum of squares)
28076        Rhead = dsqrt(   &
28077         (Rhead_distance(1)*Rhead_distance(1)) &
28078       + (Rhead_distance(2)*Rhead_distance(2)) &
28079       + (Rhead_distance(3)*Rhead_distance(3)))
28080 !c!-------------------------------------------------------------------
28081 !c! zero everything that should be zero'ed
28082        Egb = 0.0d0
28083        ECL = 0.0d0
28084        Elj = 0.0d0
28085        Equad = 0.0d0
28086        Epol = 0.0d0
28087        eheadtail = 0.0d0
28088        dGCLdOM1 = 0.0d0
28089        dGCLdOM2 = 0.0d0
28090        dGCLdOM12 = 0.0d0
28091        dPOLdOM1 = 0.0d0
28092        dPOLdOM2 = 0.0d0
28093        RETURN
28094       END SUBROUTINE elgrad_init_cat
28095
28096       SUBROUTINE elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
28097       use comm_momo
28098       use calc_data
28099        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
28100        eps_out=80.0d0
28101        itypi = 10
28102        itypj = itype(j,5)
28103 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
28104 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
28105 !c!       t_bath = 300
28106 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
28107        Rb=0.001986d0
28108        BetaT = 1.0d0 / (298.0d0 * Rb)
28109 !c! Gay-berne var's
28110        sig0ij = sigmacat( itypi,itypj )
28111        chi1   = chi1cat( itypi, itypj )
28112        chi2   = 0.0d0
28113        chi12  = 0.0d0
28114        chip1  = chipp1cat( itypi, itypj )
28115        chip2  = 0.0d0
28116        chip12 = 0.0d0
28117 !c! not used by momo potential, but needed by sc_angular which is shared
28118 !c! by all energy_potential subroutines
28119        alf1   = 0.0d0
28120        alf2   = 0.0d0
28121        alf12  = 0.0d0
28122        dxj = 0.0d0 !dc_norm( 1, nres+j )
28123        dyj = 0.0d0 !dc_norm( 2, nres+j )
28124        dzj = 0.0d0 !dc_norm( 3, nres+j )
28125 !c! distance from center of chain(?) to polar/charged head
28126        d1 = dheadcat(1, 1, itypi, itypj)
28127        d2 = dheadcat(2, 1, itypi, itypj)
28128 !c! ai*aj from Fgb
28129        a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj)
28130 !c!       a12sq = a12sq * a12sq
28131 !c! charge of amino acid itypi is...
28132        Qi  = 0
28133        Qj  = ichargecat(itypj)
28134 !       Qij = Qi * Qj
28135 !c! chis1,2,12
28136        chis1 = chis1cat(itypi,itypj)
28137        chis2 = 0.0d0
28138        chis12 = 0.0d0
28139        sig1 = sigmap1cat(itypi,itypj)
28140        sig2 = sigmap2cat(itypi,itypj)
28141 !c! alpha factors from Fcav/Gcav
28142        b1cav = alphasurcat(1,itypi,itypj)
28143        b2cav = alphasurcat(2,itypi,itypj)
28144        b3cav = alphasurcat(3,itypi,itypj)
28145        b4cav = alphasurcat(4,itypi,itypj)
28146        wqd = wquadcat(itypi, itypj)
28147 !c! used by Fgb
28148        eps_in = epsintabcat(itypi,itypj)
28149        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
28150 !c!-------------------------------------------------------------------
28151 !c! tail location and distance calculations
28152        Rtail = 0.0d0
28153        DO k = 1, 3
28154       ctail(k,1)=(c(k,i)+c(k,i+1))/2.0-dtailcat(1,itypi,itypj)*dc_norm(k,i)
28155       ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
28156        END DO
28157 !c! tail distances will be themselves usefull elswhere
28158 !c1 (in Gcav, for example)
28159        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
28160        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
28161        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
28162        Rtail = dsqrt(  &
28163         (Rtail_distance(1)*Rtail_distance(1))  &
28164       + (Rtail_distance(2)*Rtail_distance(2))  &
28165       + (Rtail_distance(3)*Rtail_distance(3)))
28166 !c!-------------------------------------------------------------------
28167 !c! Calculate location and distance between polar heads
28168 !c! distance between heads
28169 !c! for each one of our three dimensional space...
28170        d1 = dheadcat(1, 1, itypi, itypj)
28171        d2 = dheadcat(2, 1, itypi, itypj)
28172
28173        DO k = 1,3
28174 !c! location of polar head is computed by taking hydrophobic centre
28175 !c! and moving by a d1 * dc_norm vector
28176 !c! see unres publications for very informative images
28177       chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
28178       chead(k,2) = c(k, j)
28179 !c! distance
28180 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
28181 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
28182       Rhead_distance(k) = chead(k,2) - chead(k,1)
28183        END DO
28184 !c! pitagoras (root of sum of squares)
28185        Rhead = dsqrt(   &
28186         (Rhead_distance(1)*Rhead_distance(1)) &
28187       + (Rhead_distance(2)*Rhead_distance(2)) &
28188       + (Rhead_distance(3)*Rhead_distance(3)))
28189 !c!-------------------------------------------------------------------
28190 !c! zero everything that should be zero'ed
28191        Egb = 0.0d0
28192        ECL = 0.0d0
28193        Elj = 0.0d0
28194        Equad = 0.0d0
28195        Epol = 0.0d0
28196        eheadtail = 0.0d0
28197        dGCLdOM1 = 0.0d0
28198        dGCLdOM2 = 0.0d0
28199        dGCLdOM12 = 0.0d0
28200        dPOLdOM1 = 0.0d0
28201        dPOLdOM2 = 0.0d0
28202        RETURN
28203       END SUBROUTINE elgrad_init_cat_pep
28204
28205       double precision function tschebyshev(m,n,x,y)
28206       implicit none
28207       integer i,m,n
28208       double precision x(n),y,yy(0:maxvar),aux
28209 !c Tschebyshev polynomial. Note that the first term is omitted
28210 !c m=0: the constant term is included
28211 !c m=1: the constant term is not included
28212       yy(0)=1.0d0
28213       yy(1)=y
28214       do i=2,n
28215       yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
28216       enddo
28217       aux=0.0d0
28218       do i=m,n
28219       aux=aux+x(i)*yy(i)
28220       enddo
28221       tschebyshev=aux
28222       return
28223       end function tschebyshev
28224 !C--------------------------------------------------------------------------
28225       double precision function gradtschebyshev(m,n,x,y)
28226       implicit none
28227       integer i,m,n
28228       double precision x(n+1),y,yy(0:maxvar),aux
28229 !c Tschebyshev polynomial. Note that the first term is omitted
28230 !c m=0: the constant term is included
28231 !c m=1: the constant term is not included
28232       yy(0)=1.0d0
28233       yy(1)=2.0d0*y
28234       do i=2,n
28235       yy(i)=2*y*yy(i-1)-yy(i-2)
28236       enddo
28237       aux=0.0d0
28238       do i=m,n
28239       aux=aux+x(i+1)*yy(i)*(i+1)
28240 !C        print *, x(i+1),yy(i),i
28241       enddo
28242       gradtschebyshev=aux
28243       return
28244       end function gradtschebyshev
28245
28246       subroutine make_SCSC_inter_list
28247       include 'mpif.h'
28248       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
28249       real*8 :: dist_init, dist_temp,r_buff_list
28250       integer:: contlisti(250*nres),contlistj(250*nres)
28251 !      integer :: newcontlisti(200*nres),newcontlistj(200*nres)
28252       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_sc,g_ilist_sc
28253       integer displ(0:nprocs),i_ilist_sc(0:nprocs),ierr
28254 !            print *,"START make_SC"
28255         r_buff_list=5.0
28256           ilist_sc=0
28257           do i=iatsc_s,iatsc_e
28258            itypi=iabs(itype(i,1))
28259            if (itypi.eq.ntyp1) cycle
28260            xi=c(1,nres+i)
28261            yi=c(2,nres+i)
28262            zi=c(3,nres+i)
28263           call to_box(xi,yi,zi)
28264            do iint=1,nint_gr(i)
28265             do j=istart(i,iint),iend(i,iint)
28266              itypj=iabs(itype(j,1))
28267              if (itypj.eq.ntyp1) cycle
28268              xj=c(1,nres+j)
28269              yj=c(2,nres+j)
28270              zj=c(3,nres+j)
28271              call to_box(xj,yj,zj)
28272 !          call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
28273 !          faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
28274           xj=boxshift(xj-xi,boxxsize)
28275           yj=boxshift(yj-yi,boxysize)
28276           zj=boxshift(zj-zi,boxzsize)
28277           dist_init=xj**2+yj**2+zj**2
28278 !             dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
28279 ! r_buff_list is a read value for a buffer
28280              if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
28281 ! Here the list is created
28282              ilist_sc=ilist_sc+1
28283 ! this can be substituted by cantor and anti-cantor
28284              contlisti(ilist_sc)=i
28285              contlistj(ilist_sc)=j
28286
28287              endif
28288            enddo
28289            enddo
28290            enddo
28291 !         call MPI_Reduce(ilist_sc,g_ilist_sc,1,&
28292 !          MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
28293 !        call MPI_Gather(newnss,1,MPI_INTEGER,&
28294 !                        i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
28295 #ifdef DEBUG
28296       write (iout,*) "before MPIREDUCE",ilist_sc
28297       do i=1,ilist_sc
28298       write (iout,*) i,contlisti(i),contlistj(i)
28299       enddo
28300 #endif
28301       if (nfgtasks.gt.1)then
28302
28303       call MPI_Reduce(ilist_sc,g_ilist_sc,1,&
28304         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
28305 !        write(iout,*) "before bcast",g_ilist_sc
28306       call MPI_Gather(ilist_sc,1,MPI_INTEGER,&
28307                   i_ilist_sc,1,MPI_INTEGER,king,FG_COMM,IERR)
28308       displ(0)=0
28309       do i=1,nfgtasks-1,1
28310         displ(i)=i_ilist_sc(i-1)+displ(i-1)
28311       enddo
28312 !        write(iout,*) "before gather",displ(0),displ(1)
28313       call MPI_Gatherv(contlisti,ilist_sc,MPI_INTEGER,&
28314                    newcontlisti,i_ilist_sc,displ,MPI_INTEGER,&
28315                    king,FG_COMM,IERR)
28316       call MPI_Gatherv(contlistj,ilist_sc,MPI_INTEGER,&
28317                    newcontlistj,i_ilist_sc,displ,MPI_INTEGER,&
28318                    king,FG_COMM,IERR)
28319       call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM,IERR)
28320 !        write(iout,*) "before bcast",g_ilist_sc
28321 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28322       call MPI_Bcast(newcontlisti,g_ilist_sc,MPI_INT,king,FG_COMM,IERR)
28323       call MPI_Bcast(newcontlistj,g_ilist_sc,MPI_INT,king,FG_COMM,IERR)
28324
28325 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28326
28327       else
28328       g_ilist_sc=ilist_sc
28329
28330       do i=1,ilist_sc
28331       newcontlisti(i)=contlisti(i)
28332       newcontlistj(i)=contlistj(i)
28333       enddo
28334       endif
28335
28336 #ifdef DEBUG
28337       write (iout,*) "after MPIREDUCE",g_ilist_sc
28338       do i=1,g_ilist_sc
28339       write (iout,*) i,newcontlisti(i),newcontlistj(i)
28340       enddo
28341 #endif
28342       call int_bounds(g_ilist_sc,g_listscsc_start,g_listscsc_end)
28343       return
28344       end subroutine make_SCSC_inter_list
28345 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
28346
28347       subroutine make_SCp_inter_list
28348       use MD_data,  only: itime_mat
28349
28350       include 'mpif.h'
28351       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
28352       real*8 :: dist_init, dist_temp,r_buff_list
28353       integer:: contlistscpi(250*nres),contlistscpj(250*nres)
28354 !      integer :: newcontlistscpi(200*nres),newcontlistscpj(200*nres)
28355       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_scp,g_ilist_scp
28356       integer displ(0:nprocs),i_ilist_scp(0:nprocs),ierr
28357 !            print *,"START make_SC"
28358       r_buff_list=5.0
28359           ilist_scp=0
28360       do i=iatscp_s,iatscp_e
28361       if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
28362       xi=0.5D0*(c(1,i)+c(1,i+1))
28363       yi=0.5D0*(c(2,i)+c(2,i+1))
28364       zi=0.5D0*(c(3,i)+c(3,i+1))
28365         call to_box(xi,yi,zi)
28366       do iint=1,nscp_gr(i)
28367
28368       do j=iscpstart(i,iint),iscpend(i,iint)
28369         itypj=iabs(itype(j,1))
28370         if (itypj.eq.ntyp1) cycle
28371 ! Uncomment following three lines for SC-p interactions
28372 !         xj=c(1,nres+j)-xi
28373 !         yj=c(2,nres+j)-yi
28374 !         zj=c(3,nres+j)-zi
28375 ! Uncomment following three lines for Ca-p interactions
28376 !          xj=c(1,j)-xi
28377 !          yj=c(2,j)-yi
28378 !          zj=c(3,j)-zi
28379         xj=c(1,j)
28380         yj=c(2,j)
28381         zj=c(3,j)
28382         call to_box(xj,yj,zj)
28383       xj=boxshift(xj-xi,boxxsize)
28384       yj=boxshift(yj-yi,boxysize)
28385       zj=boxshift(zj-zi,boxzsize)
28386       dist_init=xj**2+yj**2+zj**2
28387 #ifdef DEBUG
28388             ! r_buff_list is a read value for a buffer
28389              if ((sqrt(dist_init).le.(r_cut_ele)).and.(ifirstrun.eq.0)) then
28390 ! Here the list is created
28391              ilist_scp_first=ilist_scp_first+1
28392 ! this can be substituted by cantor and anti-cantor
28393              contlistscpi_f(ilist_scp_first)=i
28394              contlistscpj_f(ilist_scp_first)=j
28395             endif
28396 #endif
28397 ! r_buff_list is a read value for a buffer
28398              if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
28399 ! Here the list is created
28400              ilist_scp=ilist_scp+1
28401 ! this can be substituted by cantor and anti-cantor
28402              contlistscpi(ilist_scp)=i
28403              contlistscpj(ilist_scp)=j
28404             endif
28405            enddo
28406            enddo
28407            enddo
28408 #ifdef DEBUG
28409       write (iout,*) "before MPIREDUCE",ilist_scp
28410       do i=1,ilist_scp
28411       write (iout,*) i,contlistscpi(i),contlistscpj(i)
28412       enddo
28413 #endif
28414       if (nfgtasks.gt.1)then
28415
28416       call MPI_Reduce(ilist_scp,g_ilist_scp,1,&
28417         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
28418 !        write(iout,*) "before bcast",g_ilist_sc
28419       call MPI_Gather(ilist_scp,1,MPI_INTEGER,&
28420                   i_ilist_scp,1,MPI_INTEGER,king,FG_COMM,IERR)
28421       displ(0)=0
28422       do i=1,nfgtasks-1,1
28423         displ(i)=i_ilist_scp(i-1)+displ(i-1)
28424       enddo
28425 !        write(iout,*) "before gather",displ(0),displ(1)
28426       call MPI_Gatherv(contlistscpi,ilist_scp,MPI_INTEGER,&
28427                    newcontlistscpi,i_ilist_scp,displ,MPI_INTEGER,&
28428                    king,FG_COMM,IERR)
28429       call MPI_Gatherv(contlistscpj,ilist_scp,MPI_INTEGER,&
28430                    newcontlistscpj,i_ilist_scp,displ,MPI_INTEGER,&
28431                    king,FG_COMM,IERR)
28432       call MPI_Bcast(g_ilist_scp,1,MPI_INT,king,FG_COMM,IERR)
28433 !        write(iout,*) "before bcast",g_ilist_sc
28434 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28435       call MPI_Bcast(newcontlistscpi,g_ilist_scp,MPI_INT,king,FG_COMM,IERR)
28436       call MPI_Bcast(newcontlistscpj,g_ilist_scp,MPI_INT,king,FG_COMM,IERR)
28437
28438 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28439
28440       else
28441       g_ilist_scp=ilist_scp
28442
28443       do i=1,ilist_scp
28444       newcontlistscpi(i)=contlistscpi(i)
28445       newcontlistscpj(i)=contlistscpj(i)
28446       enddo
28447       endif
28448
28449 #ifdef DEBUG
28450       write (iout,*) "after MPIREDUCE",g_ilist_scp
28451       do i=1,g_ilist_scp
28452       write (iout,*) i,newcontlistscpi(i),newcontlistscpj(i)
28453       enddo
28454
28455 !      if (ifirstrun.eq.0) ifirstrun=1
28456 !      do i=1,ilist_scp_first
28457 !       do j=1,g_ilist_scp
28458 !        if ((newcontlistscpi(j).eq.contlistscpi_f(i)).and.&
28459 !         (newcontlistscpj(j).eq.contlistscpj_f(i))) go to 126
28460 !        enddo
28461 !       print *,itime_mat,"ERROR matrix needs updating"
28462 !       print *,contlistscpi_f(i),contlistscpj_f(i)
28463 !  126  continue
28464 !      enddo
28465 #endif
28466       call int_bounds(g_ilist_scp,g_listscp_start,g_listscp_end)
28467
28468       return
28469       end subroutine make_SCp_inter_list
28470
28471 !-----------------------------------------------------------------------------
28472 !-----------------------------------------------------------------------------
28473
28474
28475       subroutine make_pp_inter_list
28476       include 'mpif.h'
28477       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
28478       real*8 :: xmedj,ymedj,zmedj,sslipi,ssgradlipi,faclipij2,sslipj,ssgradlipj
28479       real*8 :: dist_init, dist_temp,r_buff_list,dxi,dyi,dzi,xmedi,ymedi,zmedi
28480       real*8 :: dx_normi,dy_normi,dz_normi,dxj,dyj,dzj,dx_normj,dy_normj,dz_normj
28481       integer:: contlistppi(250*nres),contlistppj(250*nres)
28482 !      integer :: newcontlistppi(200*nres),newcontlistppj(200*nres)
28483       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_pp,g_ilist_pp
28484       integer displ(0:nprocs),i_ilist_pp(0:nprocs),ierr
28485 !            write(iout,*),"START make_pp",iatel_s,iatel_e,r_cut_ele+r_buff_list
28486             ilist_pp=0
28487       r_buff_list=5.0
28488       do i=iatel_s,iatel_e
28489         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
28490         dxi=dc(1,i)
28491         dyi=dc(2,i)
28492         dzi=dc(3,i)
28493         dx_normi=dc_norm(1,i)
28494         dy_normi=dc_norm(2,i)
28495         dz_normi=dc_norm(3,i)
28496         xmedi=c(1,i)+0.5d0*dxi
28497         ymedi=c(2,i)+0.5d0*dyi
28498         zmedi=c(3,i)+0.5d0*dzi
28499
28500         call to_box(xmedi,ymedi,zmedi)
28501         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
28502 !          write (iout,*) i,j,itype(i,1),itype(j,1)
28503 !          if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
28504
28505 ! 1,j)
28506              do j=ielstart(i),ielend(i)
28507 !          write (iout,*) i,j,itype(i,1),itype(j,1)
28508           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
28509           dxj=dc(1,j)
28510           dyj=dc(2,j)
28511           dzj=dc(3,j)
28512           dx_normj=dc_norm(1,j)
28513           dy_normj=dc_norm(2,j)
28514           dz_normj=dc_norm(3,j)
28515 !          xj=c(1,j)+0.5D0*dxj-xmedi
28516 !          yj=c(2,j)+0.5D0*dyj-ymedi
28517 !          zj=c(3,j)+0.5D0*dzj-zmedi
28518           xj=c(1,j)+0.5D0*dxj
28519           yj=c(2,j)+0.5D0*dyj
28520           zj=c(3,j)+0.5D0*dzj
28521           call to_box(xj,yj,zj)
28522 !          call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
28523 !          faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
28524           xj=boxshift(xj-xmedi,boxxsize)
28525           yj=boxshift(yj-ymedi,boxysize)
28526           zj=boxshift(zj-zmedi,boxzsize)
28527           dist_init=xj**2+yj**2+zj**2
28528       if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
28529 ! Here the list is created
28530                  ilist_pp=ilist_pp+1
28531 ! this can be substituted by cantor and anti-cantor
28532                  contlistppi(ilist_pp)=i
28533                  contlistppj(ilist_pp)=j
28534               endif
28535 !             enddo
28536              enddo
28537              enddo
28538 #ifdef DEBUG
28539       write (iout,*) "before MPIREDUCE",ilist_pp
28540       do i=1,ilist_pp
28541       write (iout,*) i,contlistppi(i),contlistppj(i)
28542       enddo
28543 #endif
28544       if (nfgtasks.gt.1)then
28545
28546         call MPI_Reduce(ilist_pp,g_ilist_pp,1,&
28547           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
28548 !        write(iout,*) "before bcast",g_ilist_sc
28549         call MPI_Gather(ilist_pp,1,MPI_INTEGER,&
28550                         i_ilist_pp,1,MPI_INTEGER,king,FG_COMM,IERR)
28551         displ(0)=0
28552         do i=1,nfgtasks-1,1
28553           displ(i)=i_ilist_pp(i-1)+displ(i-1)
28554         enddo
28555 !        write(iout,*) "before gather",displ(0),displ(1)
28556         call MPI_Gatherv(contlistppi,ilist_pp,MPI_INTEGER,&
28557                          newcontlistppi,i_ilist_pp,displ,MPI_INTEGER,&
28558                          king,FG_COMM,IERR)
28559         call MPI_Gatherv(contlistppj,ilist_pp,MPI_INTEGER,&
28560                          newcontlistppj,i_ilist_pp,displ,MPI_INTEGER,&
28561                          king,FG_COMM,IERR)
28562         call MPI_Bcast(g_ilist_pp,1,MPI_INT,king,FG_COMM,IERR)
28563 !        write(iout,*) "before bcast",g_ilist_sc
28564 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28565         call MPI_Bcast(newcontlistppi,g_ilist_pp,MPI_INT,king,FG_COMM,IERR)
28566         call MPI_Bcast(newcontlistppj,g_ilist_pp,MPI_INT,king,FG_COMM,IERR)
28567
28568 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28569
28570         else
28571         g_ilist_pp=ilist_pp
28572
28573         do i=1,ilist_pp
28574         newcontlistppi(i)=contlistppi(i)
28575         newcontlistppj(i)=contlistppj(i)
28576         enddo
28577         endif
28578         call int_bounds(g_ilist_pp,g_listpp_start,g_listpp_end)
28579 #ifdef DEBUG
28580       write (iout,*) "after MPIREDUCE",g_ilist_pp
28581       do i=1,g_ilist_pp
28582       write (iout,*) i,newcontlistppi(i),newcontlistppj(i)
28583       enddo
28584 #endif
28585       return
28586       end subroutine make_pp_inter_list
28587
28588 !-----------------------------------------------------------------------------
28589       double precision function boxshift(x,boxsize)
28590       implicit none
28591       double precision x,boxsize
28592       double precision xtemp
28593       xtemp=dmod(x,boxsize)
28594       if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
28595         boxshift=xtemp-boxsize
28596       else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
28597         boxshift=xtemp+boxsize
28598       else
28599         boxshift=xtemp
28600       endif
28601       return
28602       end function boxshift
28603 !-----------------------------------------------------------------------------
28604       subroutine to_box(xi,yi,zi)
28605       implicit none
28606 !      include 'DIMENSIONS'
28607 !      include 'COMMON.CHAIN'
28608       double precision xi,yi,zi
28609       xi=dmod(xi,boxxsize)
28610       if (xi.lt.0.0d0) xi=xi+boxxsize
28611       yi=dmod(yi,boxysize)
28612       if (yi.lt.0.0d0) yi=yi+boxysize
28613       zi=dmod(zi,boxzsize)
28614       if (zi.lt.0.0d0) zi=zi+boxzsize
28615       return
28616       end subroutine to_box
28617 !--------------------------------------------------------------------------
28618       subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
28619       implicit none
28620 !      include 'DIMENSIONS'
28621 !      include 'COMMON.IOUNITS'
28622 !      include 'COMMON.CHAIN'
28623       double precision xi,yi,zi,sslipi,ssgradlipi
28624       double precision fracinbuf
28625 !      double precision sscalelip,sscagradlip
28626 #ifdef DEBUG
28627       write (iout,*) "bordlipbot",bordlipbot," bordliptop",bordliptop
28628       write (iout,*) "buflipbot",buflipbot," lipbufthick",lipbufthick
28629       write (iout,*) "xi yi zi",xi,yi,zi
28630 #endif
28631       if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
28632 ! the energy transfer exist
28633         if (zi.lt.buflipbot) then
28634 ! what fraction I am in
28635           fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
28636 ! lipbufthick is thickenes of lipid buffore
28637           sslipi=sscalelip(fracinbuf)
28638           ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
28639         elseif (zi.gt.bufliptop) then
28640           fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
28641           sslipi=sscalelip(fracinbuf)
28642           ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
28643         else
28644           sslipi=1.0d0
28645           ssgradlipi=0.0
28646         endif
28647       else
28648         sslipi=0.0d0
28649         ssgradlipi=0.0
28650       endif
28651 #ifdef DEBUG
28652       write (iout,*) "sslipi",sslipi," ssgradlipi",ssgradlipi
28653 #endif
28654       return
28655       end subroutine lipid_layer
28656
28657 !--------------------------------------------------------------------------
28658 !--------------------------------------------------------------------------
28659       end module energy