source/unres/energy.F90

   1             module energy
   2 !-----------------------------------------------------------------------------
   3       use io_units
   4       use names
   5       use math
   6       use MPI_data
   7       use energy_data
   8       use control_data
   9       use geometry_data
  10       use geometry
  11 !
  12       implicit none
  13 !-----------------------------------------------------------------------------
  14 ! Max. number of contacts per residue
  15 !      integer :: maxconts
  16 !-----------------------------------------------------------------------------
  17 ! Max. number of derivatives of virtual-bond and side-chain vectors in theta
  18 ! or phi.
  19 !      integer :: maxdim
  20 !-----------------------------------------------------------------------------
  21 ! Max. number of SC contacts
  22 !      integer :: maxcont
  23 !-----------------------------------------------------------------------------
  24 ! Max. number of variables
  25       integer :: maxvar
  26 !-----------------------------------------------------------------------------
  27 ! Max number of torsional terms in SCCOR  in control_data
  28 !      integer,parameter :: maxterm_sccor=6
  29 !-----------------------------------------------------------------------------
  30 ! Maximum number of SC local term fitting function coefficiants
  31       integer,parameter :: maxsccoef=65
  32 ! Maximum number of local shielding effectors
  33 !      integer,parameter :: maxcontsshi=50
  34 !-----------------------------------------------------------------------------
  35 ! commom.calc common/calc/
  36 !-----------------------------------------------------------------------------
  37 ! commom.contacts
  38 !      common /contacts/
  39 ! Change 12/1/95 - common block CONTACTS1 included.
  40 !      common /contacts1/
  41
  42       integer,dimension(:),allocatable :: num_cont      !(maxres)
  43       integer,dimension(:,:),allocatable :: jcont      !(maxconts,maxres)
  44       real(kind=8),dimension(:,:),allocatable :: facont,ees0plist      !(maxconts,maxres)
  45       real(kind=8),dimension(:,:,:),allocatable :: gacont      !(3,maxconts,maxres)
  46       integer,dimension(:),allocatable :: ishield_list
  47       integer,dimension(:,:),allocatable ::  shield_list
  48       real(kind=8),dimension(:),allocatable :: enetube,enecavtube
  49 !
  50 ! 12/26/95 - H-bonding contacts
  51 !      common /contacts_hb/
  52       real(kind=8),dimension(:,:,:),allocatable :: gacontp_hb1,gacontp_hb2,&
  53        gacontp_hb3,gacontm_hb1,gacontm_hb2,gacontm_hb3,gacont_hbr,grij_hb_cont      !(3,maxconts,maxres)
  54       real(kind=8),dimension(:,:),allocatable :: facont_hb,ees0p,&
  55         ees0m,d_cont      !(maxconts,maxres)
  56       integer,dimension(:),allocatable :: num_cont_hb      !(maxres)
  57       integer,dimension(:,:),allocatable :: jcont_hb      !(maxconts,maxres)
  58 ! 9/23/99 Added improper rotation matrices and matrices of dipole-dipole
  59 !         interactions
  60 ! 7/25/08 commented out; not needed when cumulants used
  61 ! Interactions of pseudo-dipoles generated by loc-el interactions.
  62 !  common /dipint/
  63       real(kind=8),dimension(:,:,:),allocatable :: dip,&
  64          dipderg      !(4,maxconts,maxres)
  65       real(kind=8),dimension(:,:,:,:,:),allocatable :: dipderx !(3,5,4,maxconts,maxres)
  66 ! 10/30/99 Added other pre-computed vectors and matrices needed
  67 !          to calculate three - six-order el-loc correlation terms
  68 ! common /rotat/
  69       real(kind=8),dimension(:,:,:),allocatable :: Ug,Ugder,Ug2,Ug2der      !(2,2,maxres)
  70       real(kind=8),dimension(:,:),allocatable :: obrot,obrot2,obrot_der,&
  71        obrot2_der      !(2,maxres)
  72 !
  73 ! This common block contains vectors and matrices dependent on a single
  74 ! amino-acid residue.
  75 !      common /precomp1/
  76       real(kind=8),dimension(:,:),allocatable :: mu,muder,Ub2,Ub2der,&
  77        Ctobr,Ctobrder,Dtobr2,Dtobr2der,gUb2      !(2,maxres)
  78       real(kind=8),dimension(:,:,:),allocatable :: EUg,EUgder,CUg,&
  79        CUgder,DUg,Dugder,DtUg2,DtUg2der      !(2,2,maxres)
  80 ! This common block contains vectors and matrices dependent on two
  81 ! consecutive amino-acid residues.
  82 !      common /precomp2/
  83       real(kind=8),dimension(:,:),allocatable :: Ug2Db1t,Ug2Db1tder,&
  84        CUgb2,CUgb2der      !(2,maxres)
  85       real(kind=8),dimension(:,:,:),allocatable :: EUgC,EUgCder,&
  86        EUgD,EUgDder,DtUg2EUg,Ug2DtEUg      !(2,2,maxres)
  87       real(kind=8),dimension(:,:,:,:),allocatable :: Ug2DtEUgder,&
  88        DtUg2EUgder      !(2,2,2,maxres)
  89 !      common /rotat_old/
  90       real(kind=8),dimension(4) :: gmuij,gmuij1,gmuij2,gmuji1,gmuji2
  91       real(kind=8),dimension(:),allocatable :: costab,sintab,&
  92        costab2,sintab2      !(maxres)
  93 ! This common block contains dipole-interaction matrices and their
  94 ! Cartesian derivatives.
  95 !      common /dipmat/
  96       real(kind=8),dimension(:,:,:,:),allocatable :: a_chuj      !(2,2,maxconts,maxres)
  97       real(kind=8),dimension(:,:,:,:,:,:),allocatable :: a_chuj_der      !(2,2,3,5,maxconts,maxres)
  98 !      common /diploc/
  99       real(kind=8),dimension(2,2,2) :: AEA,AEAderg,EAEA,AECA,&
 100        AECAderg,ADtEA,ADtEA1,AEAb1,AEAb1derg,AEAb2
 101       real(kind=8),dimension(2,2,2,2) :: EAEAderg,ADtEAderg,&
 102        ADtEA1derg,AEAb2derg
 103       real(kind=8),dimension(2,2,3,5,2,2) :: AEAderx,EAEAderx,&
 104        AECAderx,ADtEAderx,ADtEA1derx
 105       real(kind=8),dimension(2,3,5,2,2,2) :: AEAb1derx,AEAb2derx
 106       real(kind=8),dimension(3,2) :: g_contij
 107       real(kind=8) :: ekont
 108 ! 12/13/2008 (again Poland-Jaruzel war anniversary)
 109 !   RE: Parallelization of 4th and higher order loc-el correlations
 110 !      common /contdistrib/
 111       integer,dimension(:),allocatable :: ncont_sent,ncont_recv !(maxres)
 112 ! ncont_sent,ncont_recv są w multibody_ello i multibody_hb
 113 !-----------------------------------------------------------------------------
 114 ! commom.deriv;
 115 !      common /derivat/
 116 !      real(kind=8),dimension(:,:),allocatable :: dcdv,dxdv !(6,maxdim)
 117 !      real(kind=8),dimension(:,:),allocatable :: dxds !(6,maxres)
 118 !      real(kind=8),dimension(:,:,:),allocatable :: gradx,gradc !(3,maxres,2)
 119       real(kind=8),dimension(:,:),allocatable :: gvdwc,gelc,gelc_long,&
 120         gvdwpp,gvdwc_scpp,gradx_scp,gvdwc_scp,ghpbx,ghpbc,&
 121         gradcorr,gradcorr_long,gradcorr5_long,gradcorr6_long,&
 122         gcorr6_turn_long,gradxorr,gradcorr5,gradcorr6,gliptran,gliptranc,&
 123         gliptranx, &
 124         gshieldx,gshieldc,gshieldc_loc,gshieldx_ec,&
 125         gshieldc_ec,gshieldc_loc_ec,gshieldx_t3, &
 126         gshieldc_t3,gshieldc_loc_t3,gshieldx_t4,gshieldc_t4, &
 127         gshieldc_loc_t4,gshieldx_ll,gshieldc_ll,gshieldc_loc_ll,&
 128         grad_shield,gg_tube,gg_tube_sc,gradafm !(3,maxres)
 129 !-----------------------------NUCLEIC GRADIENT
 130       real(kind=8),dimension(:,:),allocatable  ::gradb_nucl,gradbx_nucl, &
 131         gvdwpsb1,gelpp,gvdwpsb,gelsbc,gelsbx,gvdwsbx,gvdwsbc,gsbloc,&
 132         gsblocx,gradcorr_nucl,gradxorr_nucl,gradcorr3_nucl,gradxorr3_nucl,&
 133         gvdwpp_nucl
 134 !-----------------------------NUCLEIC-PROTEIN GRADIENT
 135       real(kind=8),dimension(:,:),allocatable  :: gvdwx_scbase,gvdwc_scbase,&
 136          gvdwx_pepbase,gvdwc_pepbase,gvdwx_scpho,gvdwc_scpho,&
 137          gvdwc_peppho
 138 !------------------------------IONS GRADIENT
 139         real(kind=8),dimension(:,:),allocatable  ::  gradcatcat, &
 140           gradpepcat,gradpepcatx,gradnuclcat,gradnuclcatx
 141 !      real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2)
 142
 143
 144       real(kind=8),dimension(:,:),allocatable :: gel_loc,gel_loc_long,&
 145         gcorr3_turn,gcorr4_turn,gcorr6_turn,gradb,gradbx !(3,maxres)
 146       real(kind=8),dimension(:),allocatable :: gel_loc_loc,&
 147         gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc,g_corr5_loc,&
 148         g_corr6_loc      !(maxvar)
 149       real(kind=8),dimension(:,:),allocatable :: gsccorc,gsccorx !(3,maxres)
 150       real(kind=8),dimension(:),allocatable :: gsccor_loc      !(maxres)
 151 !      real(kind=8),dimension(:,:,:),allocatable :: dtheta      !(3,2,maxres)
 152       real(kind=8),dimension(:,:),allocatable :: gscloc,gsclocx !(3,maxres)
 153 !      real(kind=8),dimension(:,:,:),allocatable :: dphi,dalpha,domega !(3,3,maxres)
 154       real(kind=8),dimension(:,:,:),allocatable :: grad_shield_side, &
 155          grad_shield_loc ! (3,maxcontsshileding,maxnres)
 156 !      integer :: nfl,icg
 157 !      common /deriv_loc/
 158       real(kind=8), dimension(:),allocatable :: fac_shield
 159       real(kind=8),dimension(3,5,2) :: derx,derx_turn
 160 !      common /deriv_scloc/
 161       real(kind=8),dimension(:,:),allocatable :: dXX_C1tab,dYY_C1tab,&
 162        dZZ_C1tab,dXX_Ctab,dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,&
 163        dZZ_XYZtab      !(3,maxres)
 164 !-----------------------------------------------------------------------------
 165 ! common.maxgrad
 166 !      common /maxgrad/
 167       real(kind=8) :: gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,&
 168        gradb_max,ghpbc_max,&
 169        gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
 170        gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
 171        gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
 172        gsccorx_max,gsclocx_max
 173 !-----------------------------------------------------------------------------
 174 ! common.MD
 175 !      common /back_constr/
 176       real(kind=8),dimension(:),allocatable :: dutheta,dugamma !(maxres)
 177       real(kind=8),dimension(:,:),allocatable :: duscdiff,duscdiffx !(3,maxres)
 178 !      common /qmeas/
 179       real(kind=8) :: Ucdfrag,Ucdpair
 180       real(kind=8),dimension(:,:),allocatable :: dUdconst,dUdxconst,&
 181        dqwol,dxqwol      !(3,0:MAXRES)
 182 !-----------------------------------------------------------------------------
 183 ! common.sbridge
 184 !      common /dyn_ssbond/
 185       real(kind=8),dimension(:,:),allocatable :: dyn_ssbond_ij !(maxres,maxres)
 186 !-----------------------------------------------------------------------------
 187 ! common.sccor
 188 ! Parameters of the SCCOR term
 189 !      common/sccor/
 190       real(kind=8),dimension(:,:,:,:),allocatable :: dcostau,dsintau,&
 191        dcosomicron,domicron      !(3,3,3,maxres2)
 192 !-----------------------------------------------------------------------------
 193 ! common.vectors
 194 !      common /vectors/
 195       real(kind=8),dimension(:,:),allocatable :: uy,uz !(3,maxres)
 196       real(kind=8),dimension(:,:,:,:),allocatable :: uygrad,uzgrad !(3,3,2,maxres)
 197 !-----------------------------------------------------------------------------
 198 ! common /przechowalnia/
 199       real(kind=8),dimension(:,:,:),allocatable :: zapas
 200       real(kind=8),dimension(:,:,:,:),allocatable ::zapas2 !(max_dim,maxconts,max_fg_procs)
 201       real(kind=8),dimension(:,:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
 202 !-----------------------------------------------------------------------------
 203 !-----------------------------------------------------------------------------
 204 !
 205 !
 206 !-----------------------------------------------------------------------------
 207       contains
 208 !-----------------------------------------------------------------------------
 209 ! energy_p_new_barrier.F
 210 !-----------------------------------------------------------------------------
 211       subroutine etotal(energia)
 212 !      implicit real*8 (a-h,o-z)
 213 !      include 'DIMENSIONS'
 214       use MD_data
 215 #ifndef ISNAN
 216       external proc_proc
 217 #ifdef WINPGI
 218 !MS$ATTRIBUTES C ::  proc_proc
 219 #endif
 220 #endif
 221 #ifdef MPI
 222       include "mpif.h"
 223 #endif
 224 !      include 'COMMON.SETUP'
 225 !      include 'COMMON.IOUNITS'
 226       real(kind=8),dimension(0:n_ene) :: energia
 227 !      include 'COMMON.LOCAL'
 228 !      include 'COMMON.FFIELD'
 229 !      include 'COMMON.DERIV'
 230 !      include 'COMMON.INTERACT'
 231 !      include 'COMMON.SBRIDGE'
 232 !      include 'COMMON.CHAIN'
 233 !      include 'COMMON.VAR'
 234 !      include 'COMMON.MD'
 235 !      include 'COMMON.CONTROL'
 236 !      include 'COMMON.TIME1'
 237       real(kind=8) :: time00
 238 !el local variables
 239       integer :: n_corr,n_corr1,ierror,imatupdate
 240       real(kind=8) :: etors,edihcnstr,etors_d,esccor,ehpb
 241       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,escloc,ees,eel_loc
 242       real(kind=8) :: eello_turn3,eello_turn4,estr,ebe,eliptran,etube, &
 243                       Eafmforce,ethetacnstr
 244       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
 245 ! now energies for nulceic alone parameters
 246       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 247                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 248                       ecorr3_nucl
 249 ! energies for ions
 250       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber,&
 251                       ecation_nucl
 252 ! energies for protein nucleic acid interaction
 253       real(kind=8) :: escbase,epepbase,escpho,epeppho
 254
 255 #ifdef MPI
 256       real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw
 257 ! shielding effect varibles for MPI
 258       real(kind=8) ::  fac_shieldbuf(nres), &
 259       grad_shield_locbuf1(3*maxcontsshi*nres), &
 260       grad_shield_sidebuf1(3*maxcontsshi*nres), &
 261       grad_shield_locbuf2(3*maxcontsshi*nres), &
 262       grad_shield_sidebuf2(3*maxcontsshi*nres), &
 263       grad_shieldbuf1(3*nres), &
 264       grad_shieldbuf2(3*nres)
 265
 266        integer ishield_listbuf(-1:nres), &
 267        shield_listbuf(maxcontsshi,-1:nres),k,j,i,iii,impishi,mojint,jjj
 268 !       print *,"I START ENERGY"
 269        imatupdate=100
 270 !       if (mod(itime_mat,imatupdate).eq.0) call make_SCSC_inter_list
 271 !      real(kind=8),  dimension(:),allocatable::  fac_shieldbuf
 272 !      real(kind=8), dimension(:,:,:),allocatable:: &
 273 !       grad_shield_locbuf,grad_shield_sidebuf
 274 !      real(kind=8), dimension(:,:),allocatable:: &
 275 !        grad_shieldbuf
 276 !       integer, dimension(:),allocatable:: &
 277 !       ishield_listbuf
 278 !       integer, dimension(:,:),allocatable::  shield_listbuf
 279 !       integer :: k,j,i
 280 !      if (.not.allocated(fac_shieldbuf)) then
 281 !          allocate(fac_shieldbuf(nres))
 282 !          allocate(grad_shield_locbuf(3,maxcontsshi,-1:nres))
 283 !          allocate(grad_shield_sidebuf(3,maxcontsshi,-1:nres))
 284 !          allocate(grad_shieldbuf(3,-1:nres))
 285 !          allocate(ishield_listbuf(nres))
 286 !          allocate(shield_listbuf(maxcontsshi,nres))
 287 !       endif
 288
 289 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 290 !     & " nfgtasks",nfgtasks
 291       if (nfgtasks.gt.1) then
 292         time00=MPI_Wtime()
 293 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 294         if (fg_rank.eq.0) then
 295           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 296 !          print *,"Processor",myrank," BROADCAST iorder"
 297 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 298 ! FG slaves as WEIGHTS array.
 299           weights_(1)=wsc
 300           weights_(2)=wscp
 301           weights_(3)=welec
 302           weights_(4)=wcorr
 303           weights_(5)=wcorr5
 304           weights_(6)=wcorr6
 305           weights_(7)=wel_loc
 306           weights_(8)=wturn3
 307           weights_(9)=wturn4
 308           weights_(10)=wturn6
 309           weights_(11)=wang
 310           weights_(12)=wscloc
 311           weights_(13)=wtor
 312           weights_(14)=wtor_d
 313           weights_(15)=wstrain
 314           weights_(16)=wvdwpp
 315           weights_(17)=wbond
 316           weights_(18)=scal14
 317           weights_(21)=wsccor
 318           weights_(26)=wvdwpp_nucl
 319           weights_(27)=welpp
 320           weights_(28)=wvdwpsb
 321           weights_(29)=welpsb
 322           weights_(30)=wvdwsb
 323           weights_(31)=welsb
 324           weights_(32)=wbond_nucl
 325           weights_(33)=wang_nucl
 326           weights_(34)=wsbloc
 327           weights_(35)=wtor_nucl
 328           weights_(36)=wtor_d_nucl
 329           weights_(37)=wcorr_nucl
 330           weights_(38)=wcorr3_nucl
 331           weights_(41)=wcatcat
 332           weights_(42)=wcatprot
 333           weights_(46)=wscbase
 334           weights_(47)=wpepbase
 335           weights_(48)=wscpho
 336           weights_(49)=wpeppho
 337           weights_(50)=wcatnucl
 338 !          wcatcat= weights(41)
 339 !          wcatprot=weights(42)
 340
 341 ! FG Master broadcasts the WEIGHTS_ array
 342           call MPI_Bcast(weights_(1),n_ene,&
 343              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 344         else
 345 ! FG slaves receive the WEIGHTS array
 346           call MPI_Bcast(weights(1),n_ene,&
 347               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 348           wsc=weights(1)
 349           wscp=weights(2)
 350           welec=weights(3)
 351           wcorr=weights(4)
 352           wcorr5=weights(5)
 353           wcorr6=weights(6)
 354           wel_loc=weights(7)
 355           wturn3=weights(8)
 356           wturn4=weights(9)
 357           wturn6=weights(10)
 358           wang=weights(11)
 359           wscloc=weights(12)
 360           wtor=weights(13)
 361           wtor_d=weights(14)
 362           wstrain=weights(15)
 363           wvdwpp=weights(16)
 364           wbond=weights(17)
 365           scal14=weights(18)
 366           wsccor=weights(21)
 367           wvdwpp_nucl =weights(26)
 368           welpp  =weights(27)
 369           wvdwpsb=weights(28)
 370           welpsb =weights(29)
 371           wvdwsb =weights(30)
 372           welsb  =weights(31)
 373           wbond_nucl  =weights(32)
 374           wang_nucl   =weights(33)
 375           wsbloc =weights(34)
 376           wtor_nucl   =weights(35)
 377           wtor_d_nucl =weights(36)
 378           wcorr_nucl  =weights(37)
 379           wcorr3_nucl =weights(38)
 380           wcatcat= weights(41)
 381           wcatprot=weights(42)
 382           wscbase=weights(46)
 383           wpepbase=weights(47)
 384           wscpho=weights(48)
 385           wpeppho=weights(49)
 386           wcatnucl=weights(50)
 387 !      welpsb=weights(28)*fact(1)
 388 !
 389 !      wcorr_nucl= weights(37)*fact(1)
 390 !     wcorr3_nucl=weights(38)*fact(2)
 391 !     wtor_nucl=  weights(35)*fact(1)
 392 !     wtor_d_nucl=weights(36)*fact(2)
 393
 394         endif
 395         time_Bcast=time_Bcast+MPI_Wtime()-time00
 396         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 397 !        call chainbuild_cart
 398       endif
 399 !       print *,"itime_mat",itime_mat,imatupdate
 400         if (nfgtasks.gt.1) then
 401         call MPI_Bcast(itime_mat,1,MPI_INT,king,FG_COMM,IERROR)
 402         endif
 403        if (mod(itime_mat,imatupdate).eq.0) call make_SCp_inter_list
 404 !       write (iout,*) "after make_SCp_inter_list"
 405        if (mod(itime_mat,imatupdate).eq.0) call make_SCSC_inter_list
 406 !       write (iout,*) "after make_SCSC_inter_list"
 407
 408        if (mod(itime_mat,imatupdate).eq.0) call make_pp_inter_list
 409 !       write (iout,*) "after make_pp_inter_list"
 410
 411 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 412 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 413 #else
 414 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 415 !        call int_from_cart1(.false.)
 416 !      endif
 417 #endif
 418 #ifdef TIMING
 419       time00=MPI_Wtime()
 420 #endif
 421 !
 422 ! Compute the side-chain and electrostatic interaction energy
 423 !        print *, "Before EVDW"
 424 !      goto (101,102,103,104,105,106) ipot
 425       select case(ipot)
 426 ! Lennard-Jones potential.
 427 !  101 call elj(evdw)
 428        case (1)
 429          call elj(evdw)
 430 !d    print '(a)','Exit ELJcall el'
 431 !      goto 107
 432 ! Lennard-Jones-Kihara potential (shifted).
 433 !  102 call eljk(evdw)
 434        case (2)
 435          call eljk(evdw)
 436 !      goto 107
 437 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 438 !  103 call ebp(evdw)
 439        case (3)
 440          call ebp(evdw)
 441 !      goto 107
 442 ! Gay-Berne potential (shifted LJ, angular dependence).
 443 !  104 call egb(evdw)
 444        case (4)
 445 !       print *,"MOMO",scelemode
 446         if (scelemode.eq.0) then
 447          call egb(evdw)
 448         else
 449          call emomo(evdw)
 450         endif
 451 !      goto 107
 452 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 453 !  105 call egbv(evdw)
 454        case (5)
 455          call egbv(evdw)
 456 !      goto 107
 457 ! Soft-sphere potential
 458 !  106 call e_softsphere(evdw)
 459        case (6)
 460          call e_softsphere(evdw)
 461 !
 462 ! Calculate electrostatic (H-bonding) energy of the main chain.
 463 !
 464 !  107 continue
 465        case default
 466          write(iout,*)"Wrong ipot"
 467 !         return
 468 !   50 continue
 469       end select
 470 !      continue
 471 !        print *,"after EGB"
 472 ! shielding effect
 473        if (shield_mode.eq.2) then
 474                  call set_shield_fac2
 475
 476       if (nfgtasks.gt.1) then
 477       grad_shield_sidebuf1(:)=0.0d0
 478       grad_shield_locbuf1(:)=0.0d0
 479       grad_shield_sidebuf2(:)=0.0d0
 480       grad_shield_locbuf2(:)=0.0d0
 481       grad_shieldbuf1(:)=0.0d0
 482       grad_shieldbuf2(:)=0.0d0
 483 !#define DEBUG
 484 #ifdef DEBUG
 485        write(iout,*) "befor reduce fac_shield reduce"
 486        do i=1,nres
 487         write(2,*) "fac",itype(i,1),fac_shield(i),grad_shield(1,i)
 488         write(2,*) "list", shield_list(1,i),ishield_list(i), &
 489        grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 490        enddo
 491 #endif
 492         iii=0
 493         jjj=0
 494         do i=1,nres
 495         ishield_listbuf(i)=0
 496         do k=1,3
 497         iii=iii+1
 498         grad_shieldbuf1(iii)=grad_shield(k,i)
 499         enddo
 500         enddo
 501         do i=1,nres
 502          do j=1,maxcontsshi
 503           do k=1,3
 504               jjj=jjj+1
 505               grad_shield_sidebuf1(jjj)=grad_shield_side(k,j,i)
 506               grad_shield_locbuf1(jjj)=grad_shield_loc(k,j,i)
 507            enddo
 508           enddo
 509          enddo
 510         call MPI_Allgatherv(fac_shield(ivec_start), &
 511         ivec_count(fg_rank1), &
 512         MPI_DOUBLE_PRECISION,fac_shieldbuf(1),ivec_count(0), &
 513         ivec_displ(0), &
 514         MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 515         call MPI_Allgatherv(shield_list(1,ivec_start), &
 516         ivec_count(fg_rank1), &
 517         MPI_I50,shield_listbuf(1,1),ivec_count(0), &
 518         ivec_displ(0), &
 519         MPI_I50,FG_COMM,IERROR)
 520 !        write(2,*) "After I50"
 521 !        call flush(iout)
 522         call MPI_Allgatherv(ishield_list(ivec_start), &
 523         ivec_count(fg_rank1), &
 524         MPI_INTEGER,ishield_listbuf(1),ivec_count(0), &
 525         ivec_displ(0), &
 526         MPI_INTEGER,FG_COMM,IERROR)
 527 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 528
 529 !        write(2,*) ivec_count(fg_rank1)*3,ivec_count(0)*3,ivec_displ(0)*3,3*ivec_start-2
 530 !        write (2,*) "before"
 531 !        write(2,*) grad_shieldbuf1
 532 !        call MPI_Allgatherv(grad_shieldbuf1(3*ivec_start-2), &
 533 !        ivec_count(fg_rank1)*3, &
 534 !        MPI_DOUBLE_PRECISION,grad_shieldbuf2(1),ivec_count(0), &
 535 !        ivec_count(0), &
 536 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 537         call MPI_Allreduce(grad_shieldbuf1(1),grad_shieldbuf2(1), &
 538         nres*3, &
 539         MPI_DOUBLE_PRECISION, &
 540         MPI_SUM, &
 541         FG_COMM,IERROR)
 542         call MPI_Allreduce(grad_shield_sidebuf1(1),grad_shield_sidebuf2(1), &
 543         nres*3*maxcontsshi, &
 544         MPI_DOUBLE_PRECISION, &
 545         MPI_SUM, &
 546         FG_COMM,IERROR)
 547
 548         call MPI_Allreduce(grad_shield_locbuf1(1),grad_shield_locbuf2(1), &
 549         nres*3*maxcontsshi, &
 550         MPI_DOUBLE_PRECISION, &
 551         MPI_SUM, &
 552         FG_COMM,IERROR)
 553
 554 !        write(2,*) "after"
 555 !        write(2,*) grad_shieldbuf2
 556
 557 !        call MPI_Allgatherv(grad_shield_sidebuf1(3*maxcontsshi*ivec_start-2), &
 558 !        ivec_count(fg_rank1)*3*maxcontsshi, &
 559 !        MPI_DOUBLE_PRECISION,grad_shield_sidebuf2(1),ivec_count(0)*3*maxcontsshi,&
 560 !        ivec_displ(0)*3*maxcontsshi, &
 561 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 562 !        write(2,*) "After grad_shield_side"
 563 !        call flush(iout)
 564 !        call MPI_Allgatherv(grad_shield_locbuf1(3*maxcontsshi*ivec_start-2), &
 565 !        ivec_count(fg_rank1)*3*maxcontsshi, &
 566 !        MPI_DOUBLE_PRECISION,grad_shield_locbuf2(1),ivec_count(0)*3*maxcontsshi, &
 567 !        ivec_displ(0)*3*maxcontsshi, &
 568 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 569 !        write(2,*) "After MPI_SHI"
 570 !        call flush(iout)
 571         iii=0
 572         jjj=0
 573         do i=1,nres
 574          fac_shield(i)=fac_shieldbuf(i)
 575          ishield_list(i)=ishield_listbuf(i)
 576 !         write(iout,*) i,fac_shield(i)
 577          do j=1,3
 578          iii=iii+1
 579          grad_shield(j,i)=grad_shieldbuf2(iii)
 580          enddo !j
 581          do j=1,ishield_list(i)
 582 !          write (iout,*) "ishild", ishield_list(i),i
 583            shield_list(j,i)=shield_listbuf(j,i)
 584           enddo
 585           do j=1,maxcontsshi
 586           do k=1,3
 587            jjj=jjj+1
 588           grad_shield_loc(k,j,i)=grad_shield_locbuf2(jjj)
 589           grad_shield_side(k,j,i)=grad_shield_sidebuf2(jjj)
 590           enddo !k
 591         enddo !j
 592        enddo !i
 593        endif
 594 #ifdef DEBUG
 595        write(iout,*) "after reduce fac_shield reduce"
 596        do i=1,nres
 597         write(2,*) "fac",itype(i,1),fac_shield(i),grad_shield(1,i)
 598         write(2,*) "list", shield_list(1,i),ishield_list(i), &
 599         grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 600        enddo
 601 #endif
 602 #undef DEBUG
 603        endif
 604
 605
 606
 607 !       print *,"AFTER EGB",ipot,evdw
 608 !mc
 609 !mc Sep-06: egb takes care of dynamic ss bonds too
 610 !mc
 611 !      if (dyn_ss) call dyn_set_nss
 612 !      print *,"Processor",myrank," computed USCSC"
 613 #ifdef TIMING
 614       time01=MPI_Wtime()
 615 #endif
 616       call vec_and_deriv
 617 #ifdef TIMING
 618       time_vec=time_vec+MPI_Wtime()-time01
 619 #endif
 620
 621
 622
 623
 624 !        print *,"Processor",myrank," left VEC_AND_DERIV"
 625       if (ipot.lt.6) then
 626 #ifdef SPLITELE
 627 !         print *,"after ipot if", ipot
 628          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 629              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 630              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 631              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 632 #else
 633          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 634              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 635              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 636              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 637 #endif
 638 !            print *,"just befor eelec call"
 639             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 640 !            print *, "ELEC calc"
 641          else
 642             ees=0.0d0
 643             evdw1=0.0d0
 644             eel_loc=0.0d0
 645             eello_turn3=0.0d0
 646             eello_turn4=0.0d0
 647          endif
 648       else
 649 !        write (iout,*) "Soft-spheer ELEC potential"
 650         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 651          eello_turn4)
 652       endif
 653 !      print *,"Processor",myrank," computed UELEC"
 654 !
 655 ! Calculate excluded-volume interaction energy between peptide groups
 656 ! and side chains.
 657 !
 658 !       write(iout,*) "in etotal calc exc;luded",ipot
 659
 660       if (ipot.lt.6) then
 661        if(wscp.gt.0d0) then
 662         call escp(evdw2,evdw2_14)
 663        else
 664         evdw2=0
 665         evdw2_14=0
 666        endif
 667       else
 668 !        write (iout,*) "Soft-sphere SCP potential"
 669         call escp_soft_sphere(evdw2,evdw2_14)
 670       endif
 671 !        write(iout,*) "in etotal before ebond",ipot
 672
 673 !
 674 ! Calculate the bond-stretching energy
 675 !
 676       call ebond(estr)
 677 !       print *,"EBOND",estr
 678 !       write(iout,*) "in etotal afer ebond",ipot
 679
 680 !
 681 ! Calculate the disulfide-bridge and other energy and the contributions
 682 ! from other distance constraints.
 683 !      print *,'Calling EHPB'
 684       call edis(ehpb)
 685 !elwrite(iout,*) "in etotal afer edis",ipot
 686 !      print *,'EHPB exitted succesfully.'
 687 !
 688 ! Calculate the virtual-bond-angle energy.
 689 !       write(iout,*) "in etotal afer edis",ipot
 690
 691 !      if (wang.gt.0.0d0) then
 692 !        call ebend(ebe,ethetacnstr)
 693 !      else
 694 !        ebe=0
 695 !        ethetacnstr=0
 696 !      endif
 697       if (wang.gt.0d0) then
 698        if (tor_mode.eq.0) then
 699          call ebend(ebe)
 700        else
 701 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 702 !C energy function
 703          call ebend_kcc(ebe)
 704        endif
 705       else
 706         ebe=0.0d0
 707       endif
 708       ethetacnstr=0.0d0
 709       if (with_theta_constr) call etheta_constr(ethetacnstr)
 710
 711 !       write(iout,*) "in etotal afer ebe",ipot
 712
 713 !      print *,"Processor",myrank," computed UB"
 714 !
 715 ! Calculate the SC local energy.
 716 !
 717       call esc(escloc)
 718 !elwrite(iout,*) "in etotal afer esc",ipot
 719 !      print *,"Processor",myrank," computed USC"
 720 !
 721 ! Calculate the virtual-bond torsional energy.
 722 !
 723 !d    print *,'nterm=',nterm
 724 !      if (wtor.gt.0) then
 725 !       call etor(etors,edihcnstr)
 726 !      else
 727 !       etors=0
 728 !       edihcnstr=0
 729 !      endif
 730       if (wtor.gt.0.0d0) then
 731          if (tor_mode.eq.0) then
 732            call etor(etors)
 733          else
 734 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 735 !C energy function
 736            call etor_kcc(etors)
 737          endif
 738       else
 739         etors=0.0d0
 740       endif
 741       edihcnstr=0.0d0
 742       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 743 !c      print *,"Processor",myrank," computed Utor"
 744
 745 !      print *,"Processor",myrank," computed Utor"
 746
 747 !
 748 ! 6/23/01 Calculate double-torsional energy
 749 !
 750 !elwrite(iout,*) "in etotal",ipot
 751       if (wtor_d.gt.0) then
 752        call etor_d(etors_d)
 753       else
 754        etors_d=0
 755       endif
 756 !      print *,"Processor",myrank," computed Utord"
 757 !
 758 ! 21/5/07 Calculate local sicdechain correlation energy
 759 !
 760       if (wsccor.gt.0.0d0) then
 761         call eback_sc_corr(esccor)
 762       else
 763         esccor=0.0d0
 764       endif
 765
 766 !      write(iout,*) "before multibody"
 767       call flush(iout)
 768 !      print *,"Processor",myrank," computed Usccorr"
 769 !
 770 ! 12/1/95 Multi-body terms
 771 !
 772       n_corr=0
 773       n_corr1=0
 774       call flush(iout)
 775       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 776           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 777          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 778 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 779 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 780       else
 781          ecorr=0.0d0
 782          ecorr5=0.0d0
 783          ecorr6=0.0d0
 784          eturn6=0.0d0
 785       endif
 786 !elwrite(iout,*) "in etotal",ipot
 787       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 788          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 789 !d         write (iout,*) "multibody_hb ecorr",ecorr
 790       endif
 791 !      write(iout,*) "afeter  multibody hb"
 792
 793 !      print *,"Processor",myrank," computed Ucorr"
 794 !
 795 ! If performing constraint dynamics, call the constraint energy
 796 !  after the equilibration time
 797       if(usampl.and.totT.gt.eq_time) then
 798 !elwrite(iout,*) "afeter  multibody hb"
 799          call EconstrQ
 800 !elwrite(iout,*) "afeter  multibody hb"
 801          call Econstr_back
 802 !elwrite(iout,*) "afeter  multibody hb"
 803       else
 804          Uconst=0.0d0
 805          Uconst_back=0.0d0
 806       endif
 807       call flush(iout)
 808 !         write(iout,*) "after Econstr"
 809
 810       if (wliptran.gt.0) then
 811 !        print *,"PRZED WYWOLANIEM"
 812         call Eliptransfer(eliptran)
 813       else
 814        eliptran=0.0d0
 815       endif
 816       if (fg_rank.eq.0) then
 817       if (AFMlog.gt.0) then
 818         call AFMforce(Eafmforce)
 819       else if (selfguide.gt.0) then
 820         call AFMvel(Eafmforce)
 821       else
 822         Eafmforce=0.0d0
 823       endif
 824       endif
 825       if (tubemode.eq.1) then
 826        call calctube(etube)
 827       else if (tubemode.eq.2) then
 828        call calctube2(etube)
 829       elseif (tubemode.eq.3) then
 830        call calcnano(etube)
 831       else
 832        etube=0.0d0
 833       endif
 834 !--------------------------------------------------------
 835 !       write (iout,*) "NRES_MOLEC(2),",nres_molec(2)
 836 !      print *,"before",ees,evdw1,ecorr
 837 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 838       if (nres_molec(2).gt.0) then
 839       call ebond_nucl(estr_nucl)
 840       call ebend_nucl(ebe_nucl)
 841       call etor_nucl(etors_nucl)
 842       call esb_gb(evdwsb,eelsb)
 843       call epp_nucl_sub(evdwpp,eespp)
 844       call epsb(evdwpsb,eelpsb)
 845       call esb(esbloc)
 846       call multibody_hb_nucl(ecorr_nucl,ecorr3_nucl,n_corr,n_corr1)
 847             call ecat_nucl(ecation_nucl)
 848       else
 849        etors_nucl=0.0d0
 850        estr_nucl=0.0d0
 851        ecorr3_nucl=0.0d0
 852        ecorr_nucl=0.0d0
 853        ebe_nucl=0.0d0
 854        evdwsb=0.0d0
 855        eelsb=0.0d0
 856        esbloc=0.0d0
 857        evdwpsb=0.0d0
 858        eelpsb=0.0d0
 859        evdwpp=0.0d0
 860        eespp=0.0d0
 861        etors_d_nucl=0.0d0
 862        ecation_nucl=0.0d0
 863       endif
 864 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 865 !      print *,"before ecatcat",wcatcat
 866       if (nres_molec(5).gt.0) then
 867       if (nfgtasks.gt.1) then
 868       if (fg_rank.eq.0) then
 869       call ecatcat(ecationcation)
 870       endif
 871       else
 872       call ecatcat(ecationcation)
 873       endif
 874       if (oldion.gt.0) then
 875       call ecat_prot(ecation_prot)
 876       else
 877       call ecats_prot_amber(ecation_prot)
 878       endif
 879       else
 880       ecationcation=0.0d0
 881       ecation_prot=0.0d0
 882       endif
 883       if ((nres_molec(2).gt.0).and.(nres_molec(1).gt.0)) then
 884       call eprot_sc_base(escbase)
 885       call epep_sc_base(epepbase)
 886       call eprot_sc_phosphate(escpho)
 887       call eprot_pep_phosphate(epeppho)
 888       else
 889       epepbase=0.0
 890       escbase=0.0
 891       escpho=0.0
 892       epeppho=0.0
 893       endif
 894 !      call ecatcat(ecationcation)
 895 !      print *,"after ebend", wtor_nucl
 896 #ifdef TIMING
 897       time_enecalc=time_enecalc+MPI_Wtime()-time00
 898 #endif
 899 !      print *,"Processor",myrank," computed Uconstr"
 900 #ifdef TIMING
 901       time00=MPI_Wtime()
 902 #endif
 903 !
 904 ! Sum the energies
 905 !
 906       energia(1)=evdw
 907 #ifdef SCP14
 908       energia(2)=evdw2-evdw2_14
 909       energia(18)=evdw2_14
 910 #else
 911       energia(2)=evdw2
 912       energia(18)=0.0d0
 913 #endif
 914 #ifdef SPLITELE
 915       energia(3)=ees
 916       energia(16)=evdw1
 917 #else
 918       energia(3)=ees+evdw1
 919       energia(16)=0.0d0
 920 #endif
 921       energia(4)=ecorr
 922       energia(5)=ecorr5
 923       energia(6)=ecorr6
 924       energia(7)=eel_loc
 925       energia(8)=eello_turn3
 926       energia(9)=eello_turn4
 927       energia(10)=eturn6
 928       energia(11)=ebe
 929       energia(12)=escloc
 930       energia(13)=etors
 931       energia(14)=etors_d
 932       energia(15)=ehpb
 933       energia(19)=edihcnstr
 934       energia(17)=estr
 935       energia(20)=Uconst+Uconst_back
 936       energia(21)=esccor
 937       energia(22)=eliptran
 938       energia(23)=Eafmforce
 939       energia(24)=ethetacnstr
 940       energia(25)=etube
 941 !---------------------------------------------------------------
 942       energia(26)=evdwpp
 943       energia(27)=eespp
 944       energia(28)=evdwpsb
 945       energia(29)=eelpsb
 946       energia(30)=evdwsb
 947       energia(31)=eelsb
 948       energia(32)=estr_nucl
 949       energia(33)=ebe_nucl
 950       energia(34)=esbloc
 951       energia(35)=etors_nucl
 952       energia(36)=etors_d_nucl
 953       energia(37)=ecorr_nucl
 954       energia(38)=ecorr3_nucl
 955 !----------------------------------------------------------------------
 956 !    Here are the energies showed per procesor if the are more processors
 957 !    per molecule then we sum it up in sum_energy subroutine
 958 !      print *," Processor",myrank," calls SUM_ENERGY"
 959       energia(42)=ecation_prot
 960       energia(41)=ecationcation
 961       energia(46)=escbase
 962       energia(47)=epepbase
 963       energia(48)=escpho
 964       energia(49)=epeppho
 965 !      energia(50)=ecations_prot_amber
 966       energia(50)=ecation_nucl
 967       call sum_energy(energia,.true.)
 968       if (dyn_ss) call dyn_set_nss
 969 !      print *," Processor",myrank," left SUM_ENERGY"
 970 #ifdef TIMING
 971       time_sumene=time_sumene+MPI_Wtime()-time00
 972 #endif
 973 !        call enerprint(energia)
 974 !elwrite(iout,*)"finish etotal"
 975       return
 976       end subroutine etotal
 977 !-----------------------------------------------------------------------------
 978       subroutine sum_energy(energia,reduce)
 979 !      implicit real*8 (a-h,o-z)
 980 !      include 'DIMENSIONS'
 981 #ifndef ISNAN
 982       external proc_proc
 983 #ifdef WINPGI
 984 !MS$ATTRIBUTES C ::  proc_proc
 985 #endif
 986 #endif
 987 #ifdef MPI
 988       include "mpif.h"
 989 #endif
 990 !      include 'COMMON.SETUP'
 991 !      include 'COMMON.IOUNITS'
 992       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 993 !      include 'COMMON.FFIELD'
 994 !      include 'COMMON.DERIV'
 995 !      include 'COMMON.INTERACT'
 996 !      include 'COMMON.SBRIDGE'
 997 !      include 'COMMON.CHAIN'
 998 !      include 'COMMON.VAR'
 999 !      include 'COMMON.CONTROL'
1000 !      include 'COMMON.TIME1'
1001       logical :: reduce
1002       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
1003       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
1004       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
1005         eliptran,etube, Eafmforce,ethetacnstr
1006       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1007                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1008                       ecorr3_nucl
1009       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber,&
1010                       ecation_nucl
1011       real(kind=8) :: escbase,epepbase,escpho,epeppho
1012       integer :: i
1013 #ifdef MPI
1014       integer :: ierr
1015       real(kind=8) :: time00
1016       if (nfgtasks.gt.1 .and. reduce) then
1017
1018 #ifdef DEBUG
1019         write (iout,*) "energies before REDUCE"
1020         call enerprint(energia)
1021         call flush(iout)
1022 #endif
1023         do i=0,n_ene
1024           enebuff(i)=energia(i)
1025         enddo
1026         time00=MPI_Wtime()
1027         call MPI_Barrier(FG_COMM,IERR)
1028         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
1029         time00=MPI_Wtime()
1030         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
1031           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1032 #ifdef DEBUG
1033         write (iout,*) "energies after REDUCE"
1034         call enerprint(energia)
1035         call flush(iout)
1036 #endif
1037         time_Reduce=time_Reduce+MPI_Wtime()-time00
1038       endif
1039       if (fg_rank.eq.0) then
1040 #endif
1041       evdw=energia(1)
1042 #ifdef SCP14
1043       evdw2=energia(2)+energia(18)
1044       evdw2_14=energia(18)
1045 #else
1046       evdw2=energia(2)
1047 #endif
1048 #ifdef SPLITELE
1049       ees=energia(3)
1050       evdw1=energia(16)
1051 #else
1052       ees=energia(3)
1053       evdw1=0.0d0
1054 #endif
1055       ecorr=energia(4)
1056       ecorr5=energia(5)
1057       ecorr6=energia(6)
1058       eel_loc=energia(7)
1059       eello_turn3=energia(8)
1060       eello_turn4=energia(9)
1061       eturn6=energia(10)
1062       ebe=energia(11)
1063       escloc=energia(12)
1064       etors=energia(13)
1065       etors_d=energia(14)
1066       ehpb=energia(15)
1067       edihcnstr=energia(19)
1068       estr=energia(17)
1069       Uconst=energia(20)
1070       esccor=energia(21)
1071       eliptran=energia(22)
1072       Eafmforce=energia(23)
1073       ethetacnstr=energia(24)
1074       etube=energia(25)
1075       evdwpp=energia(26)
1076       eespp=energia(27)
1077       evdwpsb=energia(28)
1078       eelpsb=energia(29)
1079       evdwsb=energia(30)
1080       eelsb=energia(31)
1081       estr_nucl=energia(32)
1082       ebe_nucl=energia(33)
1083       esbloc=energia(34)
1084       etors_nucl=energia(35)
1085       etors_d_nucl=energia(36)
1086       ecorr_nucl=energia(37)
1087       ecorr3_nucl=energia(38)
1088       ecation_prot=energia(42)
1089       ecationcation=energia(41)
1090       escbase=energia(46)
1091       epepbase=energia(47)
1092       escpho=energia(48)
1093       epeppho=energia(49)
1094       ecation_nucl=energia(50)
1095 !      ecations_prot_amber=energia(50)
1096
1097 !      energia(41)=ecation_prot
1098 !      energia(42)=ecationcation
1099
1100
1101 #ifdef SPLITELE
1102       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
1103        +wang*ebe+wtor*etors+wscloc*escloc &
1104        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1105        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1106        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1107        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1108        +Eafmforce+ethetacnstr  &
1109        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1110        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1111        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1112        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1113        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1114        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho+wcatnucl*ecation_nucl
1115 #else
1116       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
1117        +wang*ebe+wtor*etors+wscloc*escloc &
1118        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1119        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1120        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1121        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1122        +Eafmforce+ethetacnstr &
1123        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1124        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1125        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1126        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1127        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1128        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho+wcatnucl*ecation_nucl
1129 #endif
1130       energia(0)=etot
1131 ! detecting NaNQ
1132 #ifdef ISNAN
1133 #ifdef AIX
1134       if (isnan(etot).ne.0) energia(0)=1.0d+99
1135 #else
1136       if (isnan(etot)) energia(0)=1.0d+99
1137 #endif
1138 #else
1139       i=0
1140 #ifdef WINPGI
1141       idumm=proc_proc(etot,i)
1142 #else
1143       call proc_proc(etot,i)
1144 #endif
1145       if(i.eq.1)energia(0)=1.0d+99
1146 #endif
1147 #ifdef MPI
1148       endif
1149 #endif
1150 !      call enerprint(energia)
1151       call flush(iout)
1152       return
1153       end subroutine sum_energy
1154 !-----------------------------------------------------------------------------
1155       subroutine rescale_weights(t_bath)
1156 !      implicit real*8 (a-h,o-z)
1157 #ifdef MPI
1158       include 'mpif.h'
1159 #endif
1160 !      include 'DIMENSIONS'
1161 !      include 'COMMON.IOUNITS'
1162 !      include 'COMMON.FFIELD'
1163 !      include 'COMMON.SBRIDGE'
1164       real(kind=8) :: kfac=2.4d0
1165       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
1166 !el local variables
1167       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
1168       real(kind=8) :: T0=3.0d2
1169       integer :: ierror
1170 !      facT=temp0/t_bath
1171 !      facT=2*temp0/(t_bath+temp0)
1172       if (rescale_mode.eq.0) then
1173         facT(1)=1.0d0
1174         facT(2)=1.0d0
1175         facT(3)=1.0d0
1176         facT(4)=1.0d0
1177         facT(5)=1.0d0
1178         facT(6)=1.0d0
1179       else if (rescale_mode.eq.1) then
1180         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
1181         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1182         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1183         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1184         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1185 #ifdef WHAM_RUN
1186 !#if defined(WHAM_RUN) || defined(CLUSTER)
1187 #if defined(FUNCTH)
1188 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
1189         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1190 #elif defined(FUNCT)
1191         facT(6)=t_bath/T0
1192 #else
1193         facT(6)=1.0d0
1194 #endif
1195 #endif
1196       else if (rescale_mode.eq.2) then
1197         x=t_bath/temp0
1198         x2=x*x
1199         x3=x2*x
1200         x4=x3*x
1201         x5=x4*x
1202         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
1203         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
1204         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
1205         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
1206         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
1207 #ifdef WHAM_RUN
1208 !#if defined(WHAM_RUN) || defined(CLUSTER)
1209 #if defined(FUNCTH)
1210         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1211 #elif defined(FUNCT)
1212         facT(6)=t_bath/T0
1213 #else
1214         facT(6)=1.0d0
1215 #endif
1216 #endif
1217       else
1218         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1219         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1220 #ifdef MPI
1221        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1222 #endif
1223        stop 555
1224       endif
1225       welec=weights(3)*fact(1)
1226       wcorr=weights(4)*fact(3)
1227       wcorr5=weights(5)*fact(4)
1228       wcorr6=weights(6)*fact(5)
1229       wel_loc=weights(7)*fact(2)
1230       wturn3=weights(8)*fact(2)
1231       wturn4=weights(9)*fact(3)
1232       wturn6=weights(10)*fact(5)
1233       wtor=weights(13)*fact(1)
1234       wtor_d=weights(14)*fact(2)
1235       wsccor=weights(21)*fact(1)
1236       welpsb=weights(28)*fact(1)
1237       wcorr_nucl= weights(37)*fact(1)
1238       wcorr3_nucl=weights(38)*fact(2)
1239       wtor_nucl=  weights(35)*fact(1)
1240       wtor_d_nucl=weights(36)*fact(2)
1241       wpepbase=weights(47)*fact(1)
1242       return
1243       end subroutine rescale_weights
1244 !-----------------------------------------------------------------------------
1245       subroutine enerprint(energia)
1246 !      implicit real*8 (a-h,o-z)
1247 !      include 'DIMENSIONS'
1248 !      include 'COMMON.IOUNITS'
1249 !      include 'COMMON.FFIELD'
1250 !      include 'COMMON.SBRIDGE'
1251 !      include 'COMMON.MD'
1252       real(kind=8) :: energia(0:n_ene)
1253 !el local variables
1254       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
1255       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
1256       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
1257        etube,ethetacnstr,Eafmforce
1258       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1259                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1260                       ecorr3_nucl
1261       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber,&
1262                       ecation_nucl
1263       real(kind=8) :: escbase,epepbase,escpho,epeppho
1264
1265       etot=energia(0)
1266       evdw=energia(1)
1267       evdw2=energia(2)
1268 #ifdef SCP14
1269       evdw2=energia(2)+energia(18)
1270 #else
1271       evdw2=energia(2)
1272 #endif
1273       ees=energia(3)
1274 #ifdef SPLITELE
1275       evdw1=energia(16)
1276 #endif
1277       ecorr=energia(4)
1278       ecorr5=energia(5)
1279       ecorr6=energia(6)
1280       eel_loc=energia(7)
1281       eello_turn3=energia(8)
1282       eello_turn4=energia(9)
1283       eello_turn6=energia(10)
1284       ebe=energia(11)
1285       escloc=energia(12)
1286       etors=energia(13)
1287       etors_d=energia(14)
1288       ehpb=energia(15)
1289       edihcnstr=energia(19)
1290       estr=energia(17)
1291       Uconst=energia(20)
1292       esccor=energia(21)
1293       eliptran=energia(22)
1294       Eafmforce=energia(23)
1295       ethetacnstr=energia(24)
1296       etube=energia(25)
1297       evdwpp=energia(26)
1298       eespp=energia(27)
1299       evdwpsb=energia(28)
1300       eelpsb=energia(29)
1301       evdwsb=energia(30)
1302       eelsb=energia(31)
1303       estr_nucl=energia(32)
1304       ebe_nucl=energia(33)
1305       esbloc=energia(34)
1306       etors_nucl=energia(35)
1307       etors_d_nucl=energia(36)
1308       ecorr_nucl=energia(37)
1309       ecorr3_nucl=energia(38)
1310       ecation_prot=energia(42)
1311       ecationcation=energia(41)
1312       escbase=energia(46)
1313       epepbase=energia(47)
1314       escpho=energia(48)
1315       epeppho=energia(49)
1316       ecation_nucl=energia(50)
1317 !      ecations_prot_amber=energia(50)
1318 #ifdef SPLITELE
1319       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
1320         estr,wbond,ebe,wang,&
1321         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1322         ecorr,wcorr,&
1323         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1324         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
1325         edihcnstr,ethetacnstr,ebr*nss,&
1326         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
1327         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
1328         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1329         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1330         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1331         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat, &
1332         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1333         ecation_nucl,wcatnucl,etot
1334    10 format (/'Virtual-chain energies:'// &
1335        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1336        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1337        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1338        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
1339        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1340        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1341        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1342        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1343        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1344        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1345        ' (SS bridges & dist. cnstr.)'/ &
1346        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1347        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1348        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1349        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1350        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1351        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1352        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1353        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1354        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1355        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1356        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1357        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1358        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1359        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1360        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1361        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1362        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1363        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1364        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1365        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1366        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1367        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1368        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1369        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1370        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1371        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1372        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1373        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1374        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1375        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1376        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1377        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1378        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1379        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1380        'ECATBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(cation nucl-base)'/&
1381        'ETOT=  ',1pE16.6,' (total)')
1382 #else
1383       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1384         estr,wbond,ebe,wang,&
1385         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1386         ecorr,wcorr,&
1387         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1388         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1389         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforce,     &
1390         etube,wtube, &
1391         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1392         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1393         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1394         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1395         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat,  &
1396         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1397         ecation_nucl,wcatnucl,etot
1398    10 format (/'Virtual-chain energies:'// &
1399        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1400        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1401        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1402        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1403        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1404        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1405        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1406        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1407        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1408        ' (SS bridges & dist. cnstr.)'/ &
1409        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1410        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1411        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1412        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1413        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1414        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1415        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1416        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1417        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1418        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1419        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1420        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1421        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1422        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1423        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1424        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1425        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1426        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1427        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1428        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1429        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1430        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1431        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1432        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1433        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1434        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1435        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1436        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1437        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1438        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1439        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1440        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1441        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1442        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1443        'ECATBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(cation nucl-base)'/&
1444        'ETOT=  ',1pE16.6,' (total)')
1445 #endif
1446       return
1447       end subroutine enerprint
1448 !-----------------------------------------------------------------------------
1449       subroutine elj(evdw)
1450 !
1451 ! This subroutine calculates the interaction energy of nonbonded side chains
1452 ! assuming the LJ potential of interaction.
1453 !
1454 !      implicit real*8 (a-h,o-z)
1455 !      include 'DIMENSIONS'
1456       real(kind=8),parameter :: accur=1.0d-10
1457 !      include 'COMMON.GEO'
1458 !      include 'COMMON.VAR'
1459 !      include 'COMMON.LOCAL'
1460 !      include 'COMMON.CHAIN'
1461 !      include 'COMMON.DERIV'
1462 !      include 'COMMON.INTERACT'
1463 !      include 'COMMON.TORSION'
1464 !      include 'COMMON.SBRIDGE'
1465 !      include 'COMMON.NAMES'
1466 !      include 'COMMON.IOUNITS'
1467 !      include 'COMMON.CONTACTS'
1468       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1469       integer :: num_conti
1470 !el local variables
1471       integer :: i,itypi,iint,j,itypi1,itypj,k
1472       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij,sslipi,ssgradlipi,&
1473        aa,bb,sslipj,ssgradlipj
1474       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1475       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1476
1477 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1478       evdw=0.0D0
1479 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1480 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1481 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1482 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1483
1484       do i=iatsc_s,iatsc_e
1485         itypi=iabs(itype(i,1))
1486         if (itypi.eq.ntyp1) cycle
1487         itypi1=iabs(itype(i+1,1))
1488         xi=c(1,nres+i)
1489         yi=c(2,nres+i)
1490         zi=c(3,nres+i)
1491         call to_box(xi,yi,zi)
1492         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1493
1494 ! Change 12/1/95
1495         num_conti=0
1496 !
1497 ! Calculate SC interaction energy.
1498 !
1499         do iint=1,nint_gr(i)
1500 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1501 !d   &                  'iend=',iend(i,iint)
1502           do j=istart(i,iint),iend(i,iint)
1503             itypj=iabs(itype(j,1))
1504             if (itypj.eq.ntyp1) cycle
1505             xj=c(1,nres+j)-xi
1506             yj=c(2,nres+j)-yi
1507             zj=c(3,nres+j)-zi
1508             call to_box(xj,yj,zj)
1509             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1510             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1511              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1512             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1513              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1514             xj=boxshift(xj-xi,boxxsize)
1515             yj=boxshift(yj-yi,boxysize)
1516             zj=boxshift(zj-zi,boxzsize)
1517 ! Change 12/1/95 to calculate four-body interactions
1518             rij=xj*xj+yj*yj+zj*zj
1519             rrij=1.0D0/rij
1520 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1521             eps0ij=eps(itypi,itypj)
1522             fac=rrij**expon2
1523             e1=fac*fac*aa_aq(itypi,itypj)
1524             e2=fac*bb_aq(itypi,itypj)
1525             evdwij=e1+e2
1526 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1527 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1528 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1529 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1530 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1531 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1532             evdw=evdw+evdwij
1533 !
1534 ! Calculate the components of the gradient in DC and X
1535 !
1536             fac=-rrij*(e1+evdwij)
1537             gg(1)=xj*fac
1538             gg(2)=yj*fac
1539             gg(3)=zj*fac
1540             do k=1,3
1541               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1542               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1543               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1544               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1545             enddo
1546 !grad            do k=i,j-1
1547 !grad              do l=1,3
1548 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1549 !grad              enddo
1550 !grad            enddo
1551 !
1552 ! 12/1/95, revised on 5/20/97
1553 !
1554 ! Calculate the contact function. The ith column of the array JCONT will
1555 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1556 ! greater than I). The arrays FACONT and GACONT will contain the values of
1557 ! the contact function and its derivative.
1558 !
1559 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1560 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1561 ! Uncomment next line, if the correlation interactions are contact function only
1562             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1563               rij=dsqrt(rij)
1564               sigij=sigma(itypi,itypj)
1565               r0ij=rs0(itypi,itypj)
1566 !
1567 ! Check whether the SC's are not too far to make a contact.
1568 !
1569               rcut=1.5d0*r0ij
1570               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1571 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1572 !
1573               if (fcont.gt.0.0D0) then
1574 ! If the SC-SC distance if close to sigma, apply spline.
1575 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1576 !Adam &             fcont1,fprimcont1)
1577 !Adam           fcont1=1.0d0-fcont1
1578 !Adam           if (fcont1.gt.0.0d0) then
1579 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1580 !Adam             fcont=fcont*fcont1
1581 !Adam           endif
1582 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1583 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1584 !ga             do k=1,3
1585 !ga               gg(k)=gg(k)*eps0ij
1586 !ga             enddo
1587 !ga             eps0ij=-evdwij*eps0ij
1588 ! Uncomment for AL's type of SC correlation interactions.
1589 !adam           eps0ij=-evdwij
1590                 num_conti=num_conti+1
1591                 jcont(num_conti,i)=j
1592                 facont(num_conti,i)=fcont*eps0ij
1593                 fprimcont=eps0ij*fprimcont/rij
1594                 fcont=expon*fcont
1595 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1596 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1597 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1598 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1599                 gacont(1,num_conti,i)=-fprimcont*xj
1600                 gacont(2,num_conti,i)=-fprimcont*yj
1601                 gacont(3,num_conti,i)=-fprimcont*zj
1602 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1603 !d              write (iout,'(2i3,3f10.5)')
1604 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1605               endif
1606             endif
1607           enddo      ! j
1608         enddo        ! iint
1609 ! Change 12/1/95
1610         num_cont(i)=num_conti
1611       enddo          ! i
1612       do i=1,nct
1613         do j=1,3
1614           gvdwc(j,i)=expon*gvdwc(j,i)
1615           gvdwx(j,i)=expon*gvdwx(j,i)
1616         enddo
1617       enddo
1618 !******************************************************************************
1619 !
1620 !                              N O T E !!!
1621 !
1622 ! To save time, the factor of EXPON has been extracted from ALL components
1623 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1624 ! use!
1625 !
1626 !******************************************************************************
1627       return
1628       end subroutine elj
1629 !-----------------------------------------------------------------------------
1630       subroutine eljk(evdw)
1631 !
1632 ! This subroutine calculates the interaction energy of nonbonded side chains
1633 ! assuming the LJK potential of interaction.
1634 !
1635 !      implicit real*8 (a-h,o-z)
1636 !      include 'DIMENSIONS'
1637 !      include 'COMMON.GEO'
1638 !      include 'COMMON.VAR'
1639 !      include 'COMMON.LOCAL'
1640 !      include 'COMMON.CHAIN'
1641 !      include 'COMMON.DERIV'
1642 !      include 'COMMON.INTERACT'
1643 !      include 'COMMON.IOUNITS'
1644 !      include 'COMMON.NAMES'
1645       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1646       logical :: scheck
1647 !el local variables
1648       integer :: i,iint,j,itypi,itypi1,k,itypj
1649       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij, &
1650          sslipi,ssgradlipi, sslipj,ssgradlipj, aa, bb
1651       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1652
1653 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1654       evdw=0.0D0
1655       do i=iatsc_s,iatsc_e
1656         itypi=iabs(itype(i,1))
1657         if (itypi.eq.ntyp1) cycle
1658         itypi1=iabs(itype(i+1,1))
1659         xi=c(1,nres+i)
1660         yi=c(2,nres+i)
1661         zi=c(3,nres+i)
1662         call to_box(xi,yi,zi)
1663         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1664
1665 !
1666 ! Calculate SC interaction energy.
1667 !
1668         do iint=1,nint_gr(i)
1669           do j=istart(i,iint),iend(i,iint)
1670             itypj=iabs(itype(j,1))
1671             if (itypj.eq.ntyp1) cycle
1672             xj=c(1,nres+j)-xi
1673             yj=c(2,nres+j)-yi
1674             zj=c(3,nres+j)-zi
1675             call to_box(xj,yj,zj)
1676             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1677             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1678              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1679             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1680              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1681             xj=boxshift(xj-xi,boxxsize)
1682             yj=boxshift(yj-yi,boxysize)
1683             zj=boxshift(zj-zi,boxzsize)
1684             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1685             fac_augm=rrij**expon
1686             e_augm=augm(itypi,itypj)*fac_augm
1687             r_inv_ij=dsqrt(rrij)
1688             rij=1.0D0/r_inv_ij
1689             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1690             fac=r_shift_inv**expon
1691             e1=fac*fac*aa_aq(itypi,itypj)
1692             e2=fac*bb_aq(itypi,itypj)
1693             evdwij=e_augm+e1+e2
1694 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1695 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1696 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1697 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1698 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1699 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1700 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1701             evdw=evdw+evdwij
1702 !
1703 ! Calculate the components of the gradient in DC and X
1704 !
1705             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1706             gg(1)=xj*fac
1707             gg(2)=yj*fac
1708             gg(3)=zj*fac
1709             do k=1,3
1710               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1711               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1712               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1713               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1714             enddo
1715 !grad            do k=i,j-1
1716 !grad              do l=1,3
1717 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1718 !grad              enddo
1719 !grad            enddo
1720           enddo      ! j
1721         enddo        ! iint
1722       enddo          ! i
1723       do i=1,nct
1724         do j=1,3
1725           gvdwc(j,i)=expon*gvdwc(j,i)
1726           gvdwx(j,i)=expon*gvdwx(j,i)
1727         enddo
1728       enddo
1729       return
1730       end subroutine eljk
1731 !-----------------------------------------------------------------------------
1732       subroutine ebp(evdw)
1733 !
1734 ! This subroutine calculates the interaction energy of nonbonded side chains
1735 ! assuming the Berne-Pechukas potential of interaction.
1736 !
1737       use comm_srutu
1738       use calc_data
1739 !      implicit real*8 (a-h,o-z)
1740 !      include 'DIMENSIONS'
1741 !      include 'COMMON.GEO'
1742 !      include 'COMMON.VAR'
1743 !      include 'COMMON.LOCAL'
1744 !      include 'COMMON.CHAIN'
1745 !      include 'COMMON.DERIV'
1746 !      include 'COMMON.NAMES'
1747 !      include 'COMMON.INTERACT'
1748 !      include 'COMMON.IOUNITS'
1749 !      include 'COMMON.CALC'
1750       use comm_srutu
1751 !el      integer :: icall
1752 !el      common /srutu/ icall
1753 !     double precision rrsave(maxdim)
1754       logical :: lprn
1755 !el local variables
1756       integer :: iint,itypi,itypi1,itypj
1757       real(kind=8) :: rrij,xi,yi,zi, sslipi,ssgradlipi, sslipj, &
1758         ssgradlipj, aa, bb
1759       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1760
1761 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1762       evdw=0.0D0
1763 !     if (icall.eq.0) then
1764 !       lprn=.true.
1765 !     else
1766         lprn=.false.
1767 !     endif
1768 !el      ind=0
1769       do i=iatsc_s,iatsc_e
1770         itypi=iabs(itype(i,1))
1771         if (itypi.eq.ntyp1) cycle
1772         itypi1=iabs(itype(i+1,1))
1773         xi=c(1,nres+i)
1774         yi=c(2,nres+i)
1775         zi=c(3,nres+i)
1776         call to_box(xi,yi,zi)
1777         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1778         dxi=dc_norm(1,nres+i)
1779         dyi=dc_norm(2,nres+i)
1780         dzi=dc_norm(3,nres+i)
1781 !        dsci_inv=dsc_inv(itypi)
1782         dsci_inv=vbld_inv(i+nres)
1783 !
1784 ! Calculate SC interaction energy.
1785 !
1786         do iint=1,nint_gr(i)
1787           do j=istart(i,iint),iend(i,iint)
1788 !el            ind=ind+1
1789             itypj=iabs(itype(j,1))
1790             if (itypj.eq.ntyp1) cycle
1791 !            dscj_inv=dsc_inv(itypj)
1792             dscj_inv=vbld_inv(j+nres)
1793             chi1=chi(itypi,itypj)
1794             chi2=chi(itypj,itypi)
1795             chi12=chi1*chi2
1796             chip1=chip(itypi)
1797             chip2=chip(itypj)
1798             chip12=chip1*chip2
1799             alf1=alp(itypi)
1800             alf2=alp(itypj)
1801             alf12=0.5D0*(alf1+alf2)
1802 ! For diagnostics only!!!
1803 !           chi1=0.0D0
1804 !           chi2=0.0D0
1805 !           chi12=0.0D0
1806 !           chip1=0.0D0
1807 !           chip2=0.0D0
1808 !           chip12=0.0D0
1809 !           alf1=0.0D0
1810 !           alf2=0.0D0
1811 !           alf12=0.0D0
1812             xj=c(1,nres+j)-xi
1813             yj=c(2,nres+j)-yi
1814             zj=c(3,nres+j)-zi
1815             call to_box(xj,yj,zj)
1816             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1817             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1818              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1819             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1820              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1821             xj=boxshift(xj-xi,boxxsize)
1822             yj=boxshift(yj-yi,boxysize)
1823             zj=boxshift(zj-zi,boxzsize)
1824             dxj=dc_norm(1,nres+j)
1825             dyj=dc_norm(2,nres+j)
1826             dzj=dc_norm(3,nres+j)
1827             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1828 !d          if (icall.eq.0) then
1829 !d            rrsave(ind)=rrij
1830 !d          else
1831 !d            rrij=rrsave(ind)
1832 !d          endif
1833             rij=dsqrt(rrij)
1834 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1835             call sc_angular
1836 ! Calculate whole angle-dependent part of epsilon and contributions
1837 ! to its derivatives
1838             fac=(rrij*sigsq)**expon2
1839             e1=fac*fac*aa_aq(itypi,itypj)
1840             e2=fac*bb_aq(itypi,itypj)
1841             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1842             eps2der=evdwij*eps3rt
1843             eps3der=evdwij*eps2rt
1844             evdwij=evdwij*eps2rt*eps3rt
1845             evdw=evdw+evdwij
1846             if (lprn) then
1847             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1848             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1849 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1850 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1851 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1852 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1853 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1854 !d     &        evdwij
1855             endif
1856 ! Calculate gradient components.
1857             e1=e1*eps1*eps2rt**2*eps3rt**2
1858             fac=-expon*(e1+evdwij)
1859             sigder=fac/sigsq
1860             fac=rrij*fac
1861 ! Calculate radial part of the gradient
1862             gg(1)=xj*fac
1863             gg(2)=yj*fac
1864             gg(3)=zj*fac
1865 ! Calculate the angular part of the gradient and sum add the contributions
1866 ! to the appropriate components of the Cartesian gradient.
1867             call sc_grad
1868           enddo      ! j
1869         enddo        ! iint
1870       enddo          ! i
1871 !     stop
1872       return
1873       end subroutine ebp
1874 !-----------------------------------------------------------------------------
1875       subroutine egb(evdw)
1876 !
1877 ! This subroutine calculates the interaction energy of nonbonded side chains
1878 ! assuming the Gay-Berne potential of interaction.
1879 !
1880       use calc_data
1881 !      implicit real*8 (a-h,o-z)
1882 !      include 'DIMENSIONS'
1883 !      include 'COMMON.GEO'
1884 !      include 'COMMON.VAR'
1885 !      include 'COMMON.LOCAL'
1886 !      include 'COMMON.CHAIN'
1887 !      include 'COMMON.DERIV'
1888 !      include 'COMMON.NAMES'
1889 !      include 'COMMON.INTERACT'
1890 !      include 'COMMON.IOUNITS'
1891 !      include 'COMMON.CALC'
1892 !      include 'COMMON.CONTROL'
1893 !      include 'COMMON.SBRIDGE'
1894       logical :: lprn
1895 !el local variables
1896       integer :: iint,itypi,itypi1,itypj,subchap,icont
1897       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1898       real(kind=8) :: evdw,sig0ij
1899       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1900                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1901                     sslipi,sslipj,faclip
1902       integer :: ii
1903       real(kind=8) :: fracinbuf
1904
1905 !cccc      energy_dec=.false.
1906 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1907       evdw=0.0D0
1908       lprn=.false.
1909 !     if (icall.eq.0) lprn=.false.
1910 !el      ind=0
1911       dCAVdOM2=0.0d0
1912       dGCLdOM2=0.0d0
1913       dPOLdOM2=0.0d0
1914       dCAVdOM1=0.0d0
1915       dGCLdOM1=0.0d0
1916       dPOLdOM1=0.0d0
1917 !             write (iout,*) "RWA", g_listscsc_start,g_listscsc_end,i,j
1918
1919       do icont=g_listscsc_start,g_listscsc_end
1920       i=newcontlisti(icont)
1921       j=newcontlistj(icont)
1922 !      write (iout,*) "RWA", g_listscsc_start,g_listscsc_end,i,j
1923 !      do i=iatsc_s,iatsc_e
1924 !C        print *,"I am in EVDW",i
1925         itypi=iabs(itype(i,1))
1926 !        if (i.ne.47) cycle
1927         if (itypi.eq.ntyp1) cycle
1928         itypi1=iabs(itype(i+1,1))
1929         xi=c(1,nres+i)
1930         yi=c(2,nres+i)
1931         zi=c(3,nres+i)
1932         call to_box(xi,yi,zi)
1933         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1934
1935         dxi=dc_norm(1,nres+i)
1936         dyi=dc_norm(2,nres+i)
1937         dzi=dc_norm(3,nres+i)
1938 !        dsci_inv=dsc_inv(itypi)
1939         dsci_inv=vbld_inv(i+nres)
1940 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1941 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1942 !
1943 ! Calculate SC interaction energy.
1944 !
1945 !        do iint=1,nint_gr(i)
1946 !          do j=istart(i,iint),iend(i,iint)
1947             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1948               call dyn_ssbond_ene(i,j,evdwij)
1949               evdw=evdw+evdwij
1950               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1951                               'evdw',i,j,evdwij,' ss'
1952 !              if (energy_dec) write (iout,*) &
1953 !                              'evdw',i,j,evdwij,' ss'
1954              do k=j+1,iend(i,iint)
1955 !C search over all next residues
1956               if (dyn_ss_mask(k)) then
1957 !C check if they are cysteins
1958 !C              write(iout,*) 'k=',k
1959
1960 !c              write(iout,*) "PRZED TRI", evdwij
1961 !               evdwij_przed_tri=evdwij
1962               call triple_ssbond_ene(i,j,k,evdwij)
1963 !c               if(evdwij_przed_tri.ne.evdwij) then
1964 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1965 !c               endif
1966
1967 !c              write(iout,*) "PO TRI", evdwij
1968 !C call the energy function that removes the artifical triple disulfide
1969 !C bond the soubroutine is located in ssMD.F
1970               evdw=evdw+evdwij
1971               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1972                             'evdw',i,j,evdwij,'tss'
1973               endif!dyn_ss_mask(k)
1974              enddo! k
1975             ELSE
1976 !el            ind=ind+1
1977             itypj=iabs(itype(j,1))
1978             if (itypj.eq.ntyp1) cycle
1979 !             if (j.ne.78) cycle
1980 !            dscj_inv=dsc_inv(itypj)
1981             dscj_inv=vbld_inv(j+nres)
1982 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1983 !              1.0d0/vbld(j+nres) !d
1984 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1985             sig0ij=sigma(itypi,itypj)
1986             chi1=chi(itypi,itypj)
1987             chi2=chi(itypj,itypi)
1988             chi12=chi1*chi2
1989             chip1=chip(itypi)
1990             chip2=chip(itypj)
1991             chip12=chip1*chip2
1992             alf1=alp(itypi)
1993             alf2=alp(itypj)
1994             alf12=0.5D0*(alf1+alf2)
1995 ! For diagnostics only!!!
1996 !           chi1=0.0D0
1997 !           chi2=0.0D0
1998 !           chi12=0.0D0
1999 !           chip1=0.0D0
2000 !           chip2=0.0D0
2001 !           chip12=0.0D0
2002 !           alf1=0.0D0
2003 !           alf2=0.0D0
2004 !           alf12=0.0D0
2005            xj=c(1,nres+j)
2006            yj=c(2,nres+j)
2007            zj=c(3,nres+j)
2008               call to_box(xj,yj,zj)
2009               call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2010 !              write (iout,*) "KWA2", itypi,itypj
2011               aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2012                +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2013               bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2014                +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2015               xj=boxshift(xj-xi,boxxsize)
2016               yj=boxshift(yj-yi,boxysize)
2017               zj=boxshift(zj-zi,boxzsize)
2018             dxj=dc_norm(1,nres+j)
2019             dyj=dc_norm(2,nres+j)
2020             dzj=dc_norm(3,nres+j)
2021 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2022 !            write (iout,*) "j",j," dc_norm",& !d
2023 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2024 !          write(iout,*)"rrij ",rrij
2025 !          write(iout,*)"xj yj zj ", xj, yj, zj
2026 !          write(iout,*)"xi yi zi ", xi, yi, zi
2027 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
2028             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2029             rij=dsqrt(rrij)
2030             sss_ele_cut=sscale_ele(1.0d0/(rij))
2031             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
2032 !            print *,sss_ele_cut,sss_ele_grad,&
2033 !            1.0d0/(rij),r_cut_ele,rlamb_ele
2034             if (sss_ele_cut.le.0.0) cycle
2035 ! Calculate angle-dependent terms of energy and contributions to their
2036 ! derivatives.
2037             call sc_angular
2038             sigsq=1.0D0/sigsq
2039             sig=sig0ij*dsqrt(sigsq)
2040             rij_shift=1.0D0/rij-sig+sig0ij
2041 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
2042 !            "sig0ij",sig0ij
2043 ! for diagnostics; uncomment
2044 !            rij_shift=1.2*sig0ij
2045 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2046             if (rij_shift.le.0.0D0) then
2047               evdw=1.0D20
2048 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2049 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
2050 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2051               return
2052             endif
2053             sigder=-sig*sigsq
2054 !---------------------------------------------------------------
2055             rij_shift=1.0D0/rij_shift
2056             fac=rij_shift**expon
2057             faclip=fac
2058             e1=fac*fac*aa!(itypi,itypj)
2059             e2=fac*bb!(itypi,itypj)
2060             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2061             eps2der=evdwij*eps3rt
2062             eps3der=evdwij*eps2rt
2063 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
2064 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
2065 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
2066             evdwij=evdwij*eps2rt*eps3rt
2067             evdw=evdw+evdwij*sss_ele_cut
2068             if (lprn) then
2069             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2070             epsi=bb**2/aa!(itypi,itypj)
2071             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2072               restyp(itypi,1),i,restyp(itypj,1),j, &
2073               epsi,sigm,chi1,chi2,chip1,chip2, &
2074               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
2075               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
2076               evdwij
2077             endif
2078
2079             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
2080                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
2081 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
2082 !            if (energy_dec) write (iout,*) &
2083 !                             'evdw',i,j,evdwij
2084 !                       print *,"ZALAMKA", evdw
2085
2086 ! Calculate gradient components.
2087             e1=e1*eps1*eps2rt**2*eps3rt**2
2088             fac=-expon*(e1+evdwij)*rij_shift
2089             sigder=fac*sigder
2090             fac=rij*fac
2091 !            print *,'before fac',fac,rij,evdwij
2092             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
2093             *rij
2094 !            print *,'grad part scale',fac,   &
2095 !             evdwij*sss_ele_grad/sss_ele_cut &
2096 !            /sigma(itypi,itypj)*rij
2097 !            fac=0.0d0
2098 ! Calculate the radial part of the gradient
2099             gg(1)=xj*fac
2100             gg(2)=yj*fac
2101             gg(3)=zj*fac
2102 !C Calculate the radial part of the gradient
2103             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
2104        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
2105         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
2106        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2107             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2108             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2109
2110 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
2111 ! Calculate angular part of the gradient.
2112             call sc_grad
2113             ENDIF    ! dyn_ss
2114 !          enddo      ! j
2115 !        enddo        ! iint
2116       enddo          ! i
2117 !       print *,"ZALAMKA", evdw
2118 !      write (iout,*) "Number of loop steps in EGB:",ind
2119 !ccc      energy_dec=.false.
2120       return
2121       end subroutine egb
2122 !-----------------------------------------------------------------------------
2123       subroutine egbv(evdw)
2124 !
2125 ! This subroutine calculates the interaction energy of nonbonded side chains
2126 ! assuming the Gay-Berne-Vorobjev potential of interaction.
2127 !
2128       use comm_srutu
2129       use calc_data
2130 !      implicit real*8 (a-h,o-z)
2131 !      include 'DIMENSIONS'
2132 !      include 'COMMON.GEO'
2133 !      include 'COMMON.VAR'
2134 !      include 'COMMON.LOCAL'
2135 !      include 'COMMON.CHAIN'
2136 !      include 'COMMON.DERIV'
2137 !      include 'COMMON.NAMES'
2138 !      include 'COMMON.INTERACT'
2139 !      include 'COMMON.IOUNITS'
2140 !      include 'COMMON.CALC'
2141       use comm_srutu
2142 !el      integer :: icall
2143 !el      common /srutu/ icall
2144       logical :: lprn
2145 !el local variables
2146       integer :: iint,itypi,itypi1,itypj
2147       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2, &
2148          sigm,sslipi,ssgradlipi, sslipj,ssgradlipj, aa, bb
2149       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
2150
2151 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2152       evdw=0.0D0
2153       lprn=.false.
2154 !     if (icall.eq.0) lprn=.true.
2155 !el      ind=0
2156       do i=iatsc_s,iatsc_e
2157         itypi=iabs(itype(i,1))
2158         if (itypi.eq.ntyp1) cycle
2159         itypi1=iabs(itype(i+1,1))
2160         xi=c(1,nres+i)
2161         yi=c(2,nres+i)
2162         zi=c(3,nres+i)
2163         call to_box(xi,yi,zi)
2164         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2165         dxi=dc_norm(1,nres+i)
2166         dyi=dc_norm(2,nres+i)
2167         dzi=dc_norm(3,nres+i)
2168 !        dsci_inv=dsc_inv(itypi)
2169         dsci_inv=vbld_inv(i+nres)
2170 !
2171 ! Calculate SC interaction energy.
2172 !
2173         do iint=1,nint_gr(i)
2174           do j=istart(i,iint),iend(i,iint)
2175 !el            ind=ind+1
2176             itypj=iabs(itype(j,1))
2177             if (itypj.eq.ntyp1) cycle
2178 !            dscj_inv=dsc_inv(itypj)
2179             dscj_inv=vbld_inv(j+nres)
2180             sig0ij=sigma(itypi,itypj)
2181             r0ij=r0(itypi,itypj)
2182             chi1=chi(itypi,itypj)
2183             chi2=chi(itypj,itypi)
2184             chi12=chi1*chi2
2185             chip1=chip(itypi)
2186             chip2=chip(itypj)
2187             chip12=chip1*chip2
2188             alf1=alp(itypi)
2189             alf2=alp(itypj)
2190             alf12=0.5D0*(alf1+alf2)
2191 ! For diagnostics only!!!
2192 !           chi1=0.0D0
2193 !           chi2=0.0D0
2194 !           chi12=0.0D0
2195 !           chip1=0.0D0
2196 !           chip2=0.0D0
2197 !           chip12=0.0D0
2198 !           alf1=0.0D0
2199 !           alf2=0.0D0
2200 !           alf12=0.0D0
2201             xj=c(1,nres+j)-xi
2202             yj=c(2,nres+j)-yi
2203             zj=c(3,nres+j)-zi
2204            call to_box(xj,yj,zj)
2205            call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2206            aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2207             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2208            bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2209             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2210            xj=boxshift(xj-xi,boxxsize)
2211            yj=boxshift(yj-yi,boxysize)
2212            zj=boxshift(zj-zi,boxzsize)
2213             dxj=dc_norm(1,nres+j)
2214             dyj=dc_norm(2,nres+j)
2215             dzj=dc_norm(3,nres+j)
2216             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2217             rij=dsqrt(rrij)
2218 ! Calculate angle-dependent terms of energy and contributions to their
2219 ! derivatives.
2220             call sc_angular
2221             sigsq=1.0D0/sigsq
2222             sig=sig0ij*dsqrt(sigsq)
2223             rij_shift=1.0D0/rij-sig+r0ij
2224 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2225             if (rij_shift.le.0.0D0) then
2226               evdw=1.0D20
2227               return
2228             endif
2229             sigder=-sig*sigsq
2230 !---------------------------------------------------------------
2231             rij_shift=1.0D0/rij_shift
2232             fac=rij_shift**expon
2233             e1=fac*fac*aa_aq(itypi,itypj)
2234             e2=fac*bb_aq(itypi,itypj)
2235             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2236             eps2der=evdwij*eps3rt
2237             eps3der=evdwij*eps2rt
2238             fac_augm=rrij**expon
2239             e_augm=augm(itypi,itypj)*fac_augm
2240             evdwij=evdwij*eps2rt*eps3rt
2241             evdw=evdw+evdwij+e_augm
2242             if (lprn) then
2243             sigm=dabs(aa_aq(itypi,itypj)/&
2244             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
2245             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
2246             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2247               restyp(itypi,1),i,restyp(itypj,1),j,&
2248               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
2249               chi1,chi2,chip1,chip2,&
2250               eps1,eps2rt**2,eps3rt**2,&
2251               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
2252               evdwij+e_augm
2253             endif
2254 ! Calculate gradient components.
2255             e1=e1*eps1*eps2rt**2*eps3rt**2
2256             fac=-expon*(e1+evdwij)*rij_shift
2257             sigder=fac*sigder
2258             fac=rij*fac-2*expon*rrij*e_augm
2259 ! Calculate the radial part of the gradient
2260             gg(1)=xj*fac
2261             gg(2)=yj*fac
2262             gg(3)=zj*fac
2263 ! Calculate angular part of the gradient.
2264             call sc_grad
2265           enddo      ! j
2266         enddo        ! iint
2267       enddo          ! i
2268       end subroutine egbv
2269 !-----------------------------------------------------------------------------
2270 !el      subroutine sc_angular in module geometry
2271 !-----------------------------------------------------------------------------
2272       subroutine e_softsphere(evdw)
2273 !
2274 ! This subroutine calculates the interaction energy of nonbonded side chains
2275 ! assuming the LJ potential of interaction.
2276 !
2277 !      implicit real*8 (a-h,o-z)
2278 !      include 'DIMENSIONS'
2279       real(kind=8),parameter :: accur=1.0d-10
2280 !      include 'COMMON.GEO'
2281 !      include 'COMMON.VAR'
2282 !      include 'COMMON.LOCAL'
2283 !      include 'COMMON.CHAIN'
2284 !      include 'COMMON.DERIV'
2285 !      include 'COMMON.INTERACT'
2286 !      include 'COMMON.TORSION'
2287 !      include 'COMMON.SBRIDGE'
2288 !      include 'COMMON.NAMES'
2289 !      include 'COMMON.IOUNITS'
2290 !      include 'COMMON.CONTACTS'
2291       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
2292 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2293 !el local variables
2294       integer :: i,iint,j,itypi,itypi1,itypj,k
2295       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
2296       real(kind=8) :: fac
2297
2298       evdw=0.0D0
2299       do i=iatsc_s,iatsc_e
2300         itypi=iabs(itype(i,1))
2301         if (itypi.eq.ntyp1) cycle
2302         itypi1=iabs(itype(i+1,1))
2303         xi=c(1,nres+i)
2304         yi=c(2,nres+i)
2305         zi=c(3,nres+i)
2306         call to_box(xi,yi,zi)
2307
2308 !
2309 ! Calculate SC interaction energy.
2310 !
2311         do iint=1,nint_gr(i)
2312 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2313 !d   &                  'iend=',iend(i,iint)
2314           do j=istart(i,iint),iend(i,iint)
2315             itypj=iabs(itype(j,1))
2316             if (itypj.eq.ntyp1) cycle
2317             xj=boxshift(c(1,nres+j)-xi,boxxsize)
2318             yj=boxshift(c(2,nres+j)-yi,boxysize)
2319             zj=boxshift(c(3,nres+j)-zi,boxzsize)
2320             rij=xj*xj+yj*yj+zj*zj
2321 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2322             r0ij=r0(itypi,itypj)
2323             r0ijsq=r0ij*r0ij
2324 !            print *,i,j,r0ij,dsqrt(rij)
2325             if (rij.lt.r0ijsq) then
2326               evdwij=0.25d0*(rij-r0ijsq)**2
2327               fac=rij-r0ijsq
2328             else
2329               evdwij=0.0d0
2330               fac=0.0d0
2331             endif
2332             evdw=evdw+evdwij
2333 !
2334 ! Calculate the components of the gradient in DC and X
2335 !
2336             gg(1)=xj*fac
2337             gg(2)=yj*fac
2338             gg(3)=zj*fac
2339             do k=1,3
2340               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2341               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2342               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2343               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2344             enddo
2345 !grad            do k=i,j-1
2346 !grad              do l=1,3
2347 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2348 !grad              enddo
2349 !grad            enddo
2350           enddo ! j
2351         enddo ! iint
2352       enddo ! i
2353       return
2354       end subroutine e_softsphere
2355 !-----------------------------------------------------------------------------
2356       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2357 !
2358 ! Soft-sphere potential of p-p interaction
2359 !
2360 !      implicit real*8 (a-h,o-z)
2361 !      include 'DIMENSIONS'
2362 !      include 'COMMON.CONTROL'
2363 !      include 'COMMON.IOUNITS'
2364 !      include 'COMMON.GEO'
2365 !      include 'COMMON.VAR'
2366 !      include 'COMMON.LOCAL'
2367 !      include 'COMMON.CHAIN'
2368 !      include 'COMMON.DERIV'
2369 !      include 'COMMON.INTERACT'
2370 !      include 'COMMON.CONTACTS'
2371 !      include 'COMMON.TORSION'
2372 !      include 'COMMON.VECTORS'
2373 !      include 'COMMON.FFIELD'
2374       real(kind=8),dimension(3) :: ggg
2375 !d      write(iout,*) 'In EELEC_soft_sphere'
2376 !el local variables
2377       integer :: i,j,k,num_conti,iteli,itelj
2378       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2379       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2380       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2381
2382       ees=0.0D0
2383       evdw1=0.0D0
2384       eel_loc=0.0d0
2385       eello_turn3=0.0d0
2386       eello_turn4=0.0d0
2387 !el      ind=0
2388       do i=iatel_s,iatel_e
2389         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2390         dxi=dc(1,i)
2391         dyi=dc(2,i)
2392         dzi=dc(3,i)
2393         xmedi=c(1,i)+0.5d0*dxi
2394         ymedi=c(2,i)+0.5d0*dyi
2395         zmedi=c(3,i)+0.5d0*dzi
2396         call to_box(xmedi,ymedi,zmedi)
2397         num_conti=0
2398 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2399         do j=ielstart(i),ielend(i)
2400           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2401 !el          ind=ind+1
2402           iteli=itel(i)
2403           itelj=itel(j)
2404           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2405           r0ij=rpp(iteli,itelj)
2406           r0ijsq=r0ij*r0ij
2407           dxj=dc(1,j)
2408           dyj=dc(2,j)
2409           dzj=dc(3,j)
2410           xj=c(1,j)+0.5D0*dxj-xmedi
2411           yj=c(2,j)+0.5D0*dyj-ymedi
2412           zj=c(3,j)+0.5D0*dzj-zmedi
2413           call to_box(xj,yj,zj)
2414           xj=boxshift(xj-xmedi,boxxsize)
2415           yj=boxshift(yj-ymedi,boxysize)
2416           zj=boxshift(zj-zmedi,boxzsize)
2417           rij=xj*xj+yj*yj+zj*zj
2418           if (rij.lt.r0ijsq) then
2419             evdw1ij=0.25d0*(rij-r0ijsq)**2
2420             fac=rij-r0ijsq
2421           else
2422             evdw1ij=0.0d0
2423             fac=0.0d0
2424           endif
2425           evdw1=evdw1+evdw1ij
2426 !
2427 ! Calculate contributions to the Cartesian gradient.
2428 !
2429           ggg(1)=fac*xj
2430           ggg(2)=fac*yj
2431           ggg(3)=fac*zj
2432           do k=1,3
2433             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2434             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2435           enddo
2436 !
2437 ! Loop over residues i+1 thru j-1.
2438 !
2439 !grad          do k=i+1,j-1
2440 !grad            do l=1,3
2441 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2442 !grad            enddo
2443 !grad          enddo
2444         enddo ! j
2445       enddo   ! i
2446 !grad      do i=nnt,nct-1
2447 !grad        do k=1,3
2448 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2449 !grad        enddo
2450 !grad        do j=i+1,nct-1
2451 !grad          do k=1,3
2452 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2453 !grad          enddo
2454 !grad        enddo
2455 !grad      enddo
2456       return
2457       end subroutine eelec_soft_sphere
2458 !-----------------------------------------------------------------------------
2459       subroutine vec_and_deriv
2460 !      implicit real*8 (a-h,o-z)
2461 !      include 'DIMENSIONS'
2462 #ifdef MPI
2463       include 'mpif.h'
2464 #endif
2465 !      include 'COMMON.IOUNITS'
2466 !      include 'COMMON.GEO'
2467 !      include 'COMMON.VAR'
2468 !      include 'COMMON.LOCAL'
2469 !      include 'COMMON.CHAIN'
2470 !      include 'COMMON.VECTORS'
2471 !      include 'COMMON.SETUP'
2472 !      include 'COMMON.TIME1'
2473       real(kind=8),dimension(3,3,2) :: uyder,uzder
2474       real(kind=8),dimension(2) :: vbld_inv_temp
2475 ! Compute the local reference systems. For reference system (i), the
2476 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2477 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2478 !el local variables
2479       integer :: i,j,k,l
2480       real(kind=8) :: facy,fac,costh
2481
2482 #ifdef PARVEC
2483       do i=ivec_start,ivec_end
2484 #else
2485       do i=1,nres-1
2486 #endif
2487           if (i.eq.nres-1) then
2488 ! Case of the last full residue
2489 ! Compute the Z-axis
2490             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2491             costh=dcos(pi-theta(nres))
2492             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2493             do k=1,3
2494               uz(k,i)=fac*uz(k,i)
2495             enddo
2496 ! Compute the derivatives of uz
2497             uzder(1,1,1)= 0.0d0
2498             uzder(2,1,1)=-dc_norm(3,i-1)
2499             uzder(3,1,1)= dc_norm(2,i-1)
2500             uzder(1,2,1)= dc_norm(3,i-1)
2501             uzder(2,2,1)= 0.0d0
2502             uzder(3,2,1)=-dc_norm(1,i-1)
2503             uzder(1,3,1)=-dc_norm(2,i-1)
2504             uzder(2,3,1)= dc_norm(1,i-1)
2505             uzder(3,3,1)= 0.0d0
2506             uzder(1,1,2)= 0.0d0
2507             uzder(2,1,2)= dc_norm(3,i)
2508             uzder(3,1,2)=-dc_norm(2,i)
2509             uzder(1,2,2)=-dc_norm(3,i)
2510             uzder(2,2,2)= 0.0d0
2511             uzder(3,2,2)= dc_norm(1,i)
2512             uzder(1,3,2)= dc_norm(2,i)
2513             uzder(2,3,2)=-dc_norm(1,i)
2514             uzder(3,3,2)= 0.0d0
2515 ! Compute the Y-axis
2516             facy=fac
2517             do k=1,3
2518               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2519             enddo
2520 ! Compute the derivatives of uy
2521             do j=1,3
2522               do k=1,3
2523                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2524                               -dc_norm(k,i)*dc_norm(j,i-1)
2525                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2526               enddo
2527               uyder(j,j,1)=uyder(j,j,1)-costh
2528               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2529             enddo
2530             do j=1,2
2531               do k=1,3
2532                 do l=1,3
2533                   uygrad(l,k,j,i)=uyder(l,k,j)
2534                   uzgrad(l,k,j,i)=uzder(l,k,j)
2535                 enddo
2536               enddo
2537             enddo
2538             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2539             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2540             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2541             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2542           else
2543 ! Other residues
2544 ! Compute the Z-axis
2545             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2546             costh=dcos(pi-theta(i+2))
2547             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2548             do k=1,3
2549               uz(k,i)=fac*uz(k,i)
2550             enddo
2551 ! Compute the derivatives of uz
2552             uzder(1,1,1)= 0.0d0
2553             uzder(2,1,1)=-dc_norm(3,i+1)
2554             uzder(3,1,1)= dc_norm(2,i+1)
2555             uzder(1,2,1)= dc_norm(3,i+1)
2556             uzder(2,2,1)= 0.0d0
2557             uzder(3,2,1)=-dc_norm(1,i+1)
2558             uzder(1,3,1)=-dc_norm(2,i+1)
2559             uzder(2,3,1)= dc_norm(1,i+1)
2560             uzder(3,3,1)= 0.0d0
2561             uzder(1,1,2)= 0.0d0
2562             uzder(2,1,2)= dc_norm(3,i)
2563             uzder(3,1,2)=-dc_norm(2,i)
2564             uzder(1,2,2)=-dc_norm(3,i)
2565             uzder(2,2,2)= 0.0d0
2566             uzder(3,2,2)= dc_norm(1,i)
2567             uzder(1,3,2)= dc_norm(2,i)
2568             uzder(2,3,2)=-dc_norm(1,i)
2569             uzder(3,3,2)= 0.0d0
2570 ! Compute the Y-axis
2571             facy=fac
2572             do k=1,3
2573               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2574             enddo
2575 ! Compute the derivatives of uy
2576             do j=1,3
2577               do k=1,3
2578                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2579                               -dc_norm(k,i)*dc_norm(j,i+1)
2580                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2581               enddo
2582               uyder(j,j,1)=uyder(j,j,1)-costh
2583               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2584             enddo
2585             do j=1,2
2586               do k=1,3
2587                 do l=1,3
2588                   uygrad(l,k,j,i)=uyder(l,k,j)
2589                   uzgrad(l,k,j,i)=uzder(l,k,j)
2590                 enddo
2591               enddo
2592             enddo
2593             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2594             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2595             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2596             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2597           endif
2598       enddo
2599       do i=1,nres-1
2600         vbld_inv_temp(1)=vbld_inv(i+1)
2601         if (i.lt.nres-1) then
2602           vbld_inv_temp(2)=vbld_inv(i+2)
2603           else
2604           vbld_inv_temp(2)=vbld_inv(i)
2605           endif
2606         do j=1,2
2607           do k=1,3
2608             do l=1,3
2609               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2610               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2611             enddo
2612           enddo
2613         enddo
2614       enddo
2615 #if defined(PARVEC) && defined(MPI)
2616       if (nfgtasks1.gt.1) then
2617         time00=MPI_Wtime()
2618 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2619 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2620 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2621         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2622          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2623          FG_COMM1,IERR)
2624         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2625          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2626          FG_COMM1,IERR)
2627         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2628          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2629          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2630         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2631          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2632          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2633         time_gather=time_gather+MPI_Wtime()-time00
2634       endif
2635 !      if (fg_rank.eq.0) then
2636 !        write (iout,*) "Arrays UY and UZ"
2637 !        do i=1,nres-1
2638 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2639 !     &     (uz(k,i),k=1,3)
2640 !        enddo
2641 !      endif
2642 #endif
2643       return
2644       end subroutine vec_and_deriv
2645 !-----------------------------------------------------------------------------
2646       subroutine check_vecgrad
2647 !      implicit real*8 (a-h,o-z)
2648 !      include 'DIMENSIONS'
2649 !      include 'COMMON.IOUNITS'
2650 !      include 'COMMON.GEO'
2651 !      include 'COMMON.VAR'
2652 !      include 'COMMON.LOCAL'
2653 !      include 'COMMON.CHAIN'
2654 !      include 'COMMON.VECTORS'
2655       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2656       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2657       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2658       real(kind=8),dimension(3) :: erij
2659       real(kind=8) :: delta=1.0d-7
2660 !el local variables
2661       integer :: i,j,k,l
2662
2663       call vec_and_deriv
2664 !d      do i=1,nres
2665 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2666 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2667 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2668 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2669 !d     &     (dc_norm(if90,i),if90=1,3)
2670 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2671 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2672 !d          write(iout,'(a)')
2673 !d      enddo
2674       do i=1,nres
2675         do j=1,2
2676           do k=1,3
2677             do l=1,3
2678               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2679               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2680             enddo
2681           enddo
2682         enddo
2683       enddo
2684       call vec_and_deriv
2685       do i=1,nres
2686         do j=1,3
2687           uyt(j,i)=uy(j,i)
2688           uzt(j,i)=uz(j,i)
2689         enddo
2690       enddo
2691       do i=1,nres
2692 !d        write (iout,*) 'i=',i
2693         do k=1,3
2694           erij(k)=dc_norm(k,i)
2695         enddo
2696         do j=1,3
2697           do k=1,3
2698             dc_norm(k,i)=erij(k)
2699           enddo
2700           dc_norm(j,i)=dc_norm(j,i)+delta
2701 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2702 !          do k=1,3
2703 !            dc_norm(k,i)=dc_norm(k,i)/fac
2704 !          enddo
2705 !          write (iout,*) (dc_norm(k,i),k=1,3)
2706 !          write (iout,*) (erij(k),k=1,3)
2707           call vec_and_deriv
2708           do k=1,3
2709             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2710             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2711             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2712             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2713           enddo
2714 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2715 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2716 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2717         enddo
2718         do k=1,3
2719           dc_norm(k,i)=erij(k)
2720         enddo
2721 !d        do k=1,3
2722 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2723 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2724 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2725 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2726 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2727 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2728 !d          write (iout,'(a)')
2729 !d        enddo
2730       enddo
2731       return
2732       end subroutine check_vecgrad
2733 !-----------------------------------------------------------------------------
2734       subroutine set_matrices
2735 !      implicit real*8 (a-h,o-z)
2736 !      include 'DIMENSIONS'
2737 #ifdef MPI
2738       include "mpif.h"
2739 !      include "COMMON.SETUP"
2740       integer :: IERR
2741       integer :: status(MPI_STATUS_SIZE)
2742 #endif
2743 !      include 'COMMON.IOUNITS'
2744 !      include 'COMMON.GEO'
2745 !      include 'COMMON.VAR'
2746 !      include 'COMMON.LOCAL'
2747 !      include 'COMMON.CHAIN'
2748 !      include 'COMMON.DERIV'
2749 !      include 'COMMON.INTERACT'
2750 !      include 'COMMON.CONTACTS'
2751 !      include 'COMMON.TORSION'
2752 !      include 'COMMON.VECTORS'
2753 !      include 'COMMON.FFIELD'
2754       real(kind=8) :: auxvec(2),auxmat(2,2)
2755       integer :: i,iti1,iti,k,l
2756       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2,cost1,sint1,&
2757        sint1sq,sint1cub,sint1cost1,b1k,b2k,aux
2758 !       print *,"in set matrices"
2759 !
2760 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2761 ! to calculate the el-loc multibody terms of various order.
2762 !
2763 !AL el      mu=0.0d0
2764
2765 #ifdef PARMAT
2766       do i=ivec_start+2,ivec_end+2
2767 #else
2768       do i=3,nres+1
2769 #endif
2770         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2771           if (itype(i-2,1).eq.0) then
2772           iti = nloctyp
2773           else
2774           iti = itype2loc(itype(i-2,1))
2775           endif
2776         else
2777           iti=nloctyp
2778         endif
2779 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2780         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2781           iti1 = itype2loc(itype(i-1,1))
2782         else
2783           iti1=nloctyp
2784         endif
2785 !        print *,i,itype(i-2,1),iti
2786 #ifdef NEWCORR
2787         cost1=dcos(theta(i-1))
2788         sint1=dsin(theta(i-1))
2789         sint1sq=sint1*sint1
2790         sint1cub=sint1sq*sint1
2791         sint1cost1=2*sint1*cost1
2792 !        print *,"cost1",cost1,theta(i-1)
2793 !c        write (iout,*) "bnew1",i,iti
2794 !c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2795 !c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2796 !c        write (iout,*) "bnew2",i,iti
2797 !c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2798 !c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2799         k=1
2800 !        print *,bnew1(1,k,iti),"bnew1"
2801         do k=1,2
2802           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2803 !          print *,b1k
2804 !          write(*,*) shape(b1)
2805 !          if(.not.allocated(b1)) print *, "WTF?"
2806           b1(k,i-2)=sint1*b1k
2807 !
2808 !             print *,b1(k,i-2)
2809
2810           gtb1(k,i-2)=cost1*b1k-sint1sq*&
2811                    (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2812 !             print *,gtb1(k,i-2)
2813
2814           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2815           b2(k,i-2)=sint1*b2k
2816 !             print *,b2(k,i-2)
2817
2818           gtb2(k,i-2)=cost1*b2k-sint1sq*&
2819                    (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2820 !             print *,gtb2(k,i-2)
2821
2822         enddo
2823 !        print *,b1k,b2k
2824         do k=1,2
2825           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2826           cc(1,k,i-2)=sint1sq*aux
2827           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*&
2828                    (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2829           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2830           dd(1,k,i-2)=sint1sq*aux
2831           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*&
2832                    (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2833         enddo
2834 !        print *,"after cc"
2835         cc(2,1,i-2)=cc(1,2,i-2)
2836         cc(2,2,i-2)=-cc(1,1,i-2)
2837         gtcc(2,1,i-2)=gtcc(1,2,i-2)
2838         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2839         dd(2,1,i-2)=dd(1,2,i-2)
2840         dd(2,2,i-2)=-dd(1,1,i-2)
2841         gtdd(2,1,i-2)=gtdd(1,2,i-2)
2842         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2843 !        print *,"after dd"
2844
2845         do k=1,2
2846           do l=1,2
2847             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2848             EE(l,k,i-2)=sint1sq*aux
2849             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2850           enddo
2851         enddo
2852         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2853         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2854         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2855         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2856         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2857         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2858         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2859 !        print *,"after ee"
2860
2861 !c        b1tilde(1,i-2)=b1(1,i-2)
2862 !c        b1tilde(2,i-2)=-b1(2,i-2)
2863 !c        b2tilde(1,i-2)=b2(1,i-2)
2864 !c        b2tilde(2,i-2)=-b2(2,i-2)
2865 #ifdef DEBUG
2866         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2867         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
2868         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
2869         write (iout,*) 'theta=', theta(i-1)
2870 #endif
2871 #else
2872         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2873 !         write(iout,*) "i,",molnum(i),nloctyp
2874 !         print *, "i,",molnum(i),i,itype(i-2,1)
2875         if (molnum(i).eq.1) then
2876           if (itype(i-2,1).eq.ntyp1) then
2877            iti=nloctyp
2878           else
2879           iti = itype2loc(itype(i-2,1))
2880           endif
2881         else
2882           iti=nloctyp
2883         endif
2884         else
2885           iti=nloctyp
2886         endif
2887 !c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
2888 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2889         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2890           iti1 = itype2loc(itype(i-1,1))
2891         else
2892           iti1=nloctyp
2893         endif
2894 !        print *,i,iti
2895         b1(1,i-2)=b(3,iti)
2896         b1(2,i-2)=b(5,iti)
2897         b2(1,i-2)=b(2,iti)
2898         b2(2,i-2)=b(4,iti)
2899         do k=1,2
2900           do l=1,2
2901            CC(k,l,i-2)=ccold(k,l,iti)
2902            DD(k,l,i-2)=ddold(k,l,iti)
2903            EE(k,l,i-2)=eeold(k,l,iti)
2904           enddo
2905         enddo
2906 #endif
2907         b1tilde(1,i-2)= b1(1,i-2)
2908         b1tilde(2,i-2)=-b1(2,i-2)
2909         b2tilde(1,i-2)= b2(1,i-2)
2910         b2tilde(2,i-2)=-b2(2,i-2)
2911 !c
2912         Ctilde(1,1,i-2)= CC(1,1,i-2)
2913         Ctilde(1,2,i-2)= CC(1,2,i-2)
2914         Ctilde(2,1,i-2)=-CC(2,1,i-2)
2915         Ctilde(2,2,i-2)=-CC(2,2,i-2)
2916 !c
2917         Dtilde(1,1,i-2)= DD(1,1,i-2)
2918         Dtilde(1,2,i-2)= DD(1,2,i-2)
2919         Dtilde(2,1,i-2)=-DD(2,1,i-2)
2920         Dtilde(2,2,i-2)=-DD(2,2,i-2)
2921       enddo
2922 #ifdef PARMAT
2923       do i=ivec_start+2,ivec_end+2
2924 #else
2925       do i=3,nres+1
2926 #endif
2927
2928 !      print *,i,"i"
2929         if (i .lt. nres+1) then
2930           sin1=dsin(phi(i))
2931           cos1=dcos(phi(i))
2932           sintab(i-2)=sin1
2933           costab(i-2)=cos1
2934           obrot(1,i-2)=cos1
2935           obrot(2,i-2)=sin1
2936           sin2=dsin(2*phi(i))
2937           cos2=dcos(2*phi(i))
2938           sintab2(i-2)=sin2
2939           costab2(i-2)=cos2
2940           obrot2(1,i-2)=cos2
2941           obrot2(2,i-2)=sin2
2942           Ug(1,1,i-2)=-cos1
2943           Ug(1,2,i-2)=-sin1
2944           Ug(2,1,i-2)=-sin1
2945           Ug(2,2,i-2)= cos1
2946           Ug2(1,1,i-2)=-cos2
2947           Ug2(1,2,i-2)=-sin2
2948           Ug2(2,1,i-2)=-sin2
2949           Ug2(2,2,i-2)= cos2
2950         else
2951           costab(i-2)=1.0d0
2952           sintab(i-2)=0.0d0
2953           obrot(1,i-2)=1.0d0
2954           obrot(2,i-2)=0.0d0
2955           obrot2(1,i-2)=0.0d0
2956           obrot2(2,i-2)=0.0d0
2957           Ug(1,1,i-2)=1.0d0
2958           Ug(1,2,i-2)=0.0d0
2959           Ug(2,1,i-2)=0.0d0
2960           Ug(2,2,i-2)=1.0d0
2961           Ug2(1,1,i-2)=0.0d0
2962           Ug2(1,2,i-2)=0.0d0
2963           Ug2(2,1,i-2)=0.0d0
2964           Ug2(2,2,i-2)=0.0d0
2965         endif
2966         if (i .gt. 3 .and. i .lt. nres+1) then
2967           obrot_der(1,i-2)=-sin1
2968           obrot_der(2,i-2)= cos1
2969           Ugder(1,1,i-2)= sin1
2970           Ugder(1,2,i-2)=-cos1
2971           Ugder(2,1,i-2)=-cos1
2972           Ugder(2,2,i-2)=-sin1
2973           dwacos2=cos2+cos2
2974           dwasin2=sin2+sin2
2975           obrot2_der(1,i-2)=-dwasin2
2976           obrot2_der(2,i-2)= dwacos2
2977           Ug2der(1,1,i-2)= dwasin2
2978           Ug2der(1,2,i-2)=-dwacos2
2979           Ug2der(2,1,i-2)=-dwacos2
2980           Ug2der(2,2,i-2)=-dwasin2
2981         else
2982           obrot_der(1,i-2)=0.0d0
2983           obrot_der(2,i-2)=0.0d0
2984           Ugder(1,1,i-2)=0.0d0
2985           Ugder(1,2,i-2)=0.0d0
2986           Ugder(2,1,i-2)=0.0d0
2987           Ugder(2,2,i-2)=0.0d0
2988           obrot2_der(1,i-2)=0.0d0
2989           obrot2_der(2,i-2)=0.0d0
2990           Ug2der(1,1,i-2)=0.0d0
2991           Ug2der(1,2,i-2)=0.0d0
2992           Ug2der(2,1,i-2)=0.0d0
2993           Ug2der(2,2,i-2)=0.0d0
2994         endif
2995 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2996         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2997            if (itype(i-2,1).eq.0) then
2998           iti=ntortyp+1
2999            else
3000           iti = itype2loc(itype(i-2,1))
3001            endif
3002         else
3003           iti=nloctyp
3004         endif
3005 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3006         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3007            if (itype(i-1,1).eq.0) then
3008           iti1=nloctyp
3009            else
3010           iti1 = itype2loc(itype(i-1,1))
3011            endif
3012         else
3013           iti1=nloctyp
3014         endif
3015 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
3016 !d        write (iout,*) '*******i',i,' iti1',iti
3017 !        write (iout,*) 'b1',b1(:,iti)
3018 !        write (iout,*) 'b2',b2(:,i-2)
3019 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
3020 !        if (i .gt. iatel_s+2) then
3021         if (i .gt. nnt+2) then
3022           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3023 #ifdef NEWCORR
3024           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3025 !c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3026 #endif
3027
3028           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3029           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3030           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3031           then
3032           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3033           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3034           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3035           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3036           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3037           endif
3038         else
3039           do k=1,2
3040             Ub2(k,i-2)=0.0d0
3041             Ctobr(k,i-2)=0.0d0
3042             Dtobr2(k,i-2)=0.0d0
3043             do l=1,2
3044               EUg(l,k,i-2)=0.0d0
3045               CUg(l,k,i-2)=0.0d0
3046               DUg(l,k,i-2)=0.0d0
3047               DtUg2(l,k,i-2)=0.0d0
3048             enddo
3049           enddo
3050         endif
3051         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3052         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3053         do k=1,2
3054           muder(k,i-2)=Ub2der(k,i-2)
3055         enddo
3056 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3057         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3058           if (itype(i-1,1).eq.0) then
3059            iti1=nloctyp
3060           elseif (itype(i-1,1).le.ntyp) then
3061             iti1 = itype2loc(itype(i-1,1))
3062           else
3063             iti1=nloctyp
3064           endif
3065         else
3066           iti1=nloctyp
3067         endif
3068         do k=1,2
3069           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3070         enddo
3071         if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
3072         if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,i-1)
3073         if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
3074 !d        write (iout,*) 'mu1',mu1(:,i-2)
3075 !d        write (iout,*) 'mu2',mu2(:,i-2)
3076         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3077         then
3078         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3079         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3080         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3081         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3082         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3083 ! Vectors and matrices dependent on a single virtual-bond dihedral.
3084         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3085         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3086         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3087         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3088         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3089         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3090         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3091         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3092         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3093         endif
3094       enddo
3095 ! Matrices dependent on two consecutive virtual-bond dihedrals.
3096 ! The order of matrices is from left to right.
3097       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3098       then
3099 !      do i=max0(ivec_start,2),ivec_end
3100       do i=2,nres-1
3101         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3102         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3103         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3104         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3105         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3106         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3107         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3108         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3109       enddo
3110       endif
3111 #if defined(MPI) && defined(PARMAT)
3112 #ifdef DEBUG
3113 !      if (fg_rank.eq.0) then
3114         write (iout,*) "Arrays UG and UGDER before GATHER"
3115         do i=1,nres-1
3116           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3117            ((ug(l,k,i),l=1,2),k=1,2),&
3118            ((ugder(l,k,i),l=1,2),k=1,2)
3119         enddo
3120         write (iout,*) "Arrays UG2 and UG2DER"
3121         do i=1,nres-1
3122           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3123            ((ug2(l,k,i),l=1,2),k=1,2),&
3124            ((ug2der(l,k,i),l=1,2),k=1,2)
3125         enddo
3126         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3127         do i=1,nres-1
3128           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3129            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3130            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3131         enddo
3132         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3133         do i=1,nres-1
3134           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3135            costab(i),sintab(i),costab2(i),sintab2(i)
3136         enddo
3137         write (iout,*) "Array MUDER"
3138         do i=1,nres-1
3139           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3140         enddo
3141 !      endif
3142 #endif
3143       if (nfgtasks.gt.1) then
3144         time00=MPI_Wtime()
3145 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3146 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3147 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3148 #ifdef MATGATHER
3149         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
3150          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3151          FG_COMM1,IERR)
3152         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
3153          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3154          FG_COMM1,IERR)
3155         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
3156          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3157          FG_COMM1,IERR)
3158         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
3159          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3160          FG_COMM1,IERR)
3161         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
3162          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3163          FG_COMM1,IERR)
3164         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
3165          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3166          FG_COMM1,IERR)
3167         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
3168          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
3169          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3170         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
3171          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
3172          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3173         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
3174          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
3175          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3176         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
3177          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
3178          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3179         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3180         then
3181         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
3182          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3183          FG_COMM1,IERR)
3184         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
3185          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3186          FG_COMM1,IERR)
3187         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
3188          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3189          FG_COMM1,IERR)
3190        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
3191          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3192          FG_COMM1,IERR)
3193         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
3194          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3195          FG_COMM1,IERR)
3196         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
3197          ivec_count(fg_rank1),&
3198          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3199          FG_COMM1,IERR)
3200         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
3201          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3202          FG_COMM1,IERR)
3203         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
3204          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3205          FG_COMM1,IERR)
3206         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
3207          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3208          FG_COMM1,IERR)
3209         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
3210          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3211          FG_COMM1,IERR)
3212         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
3213          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3214          FG_COMM1,IERR)
3215         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
3216          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3217          FG_COMM1,IERR)
3218         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
3219          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3220          FG_COMM1,IERR)
3221         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
3222          ivec_count(fg_rank1),&
3223          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3224          FG_COMM1,IERR)
3225         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
3226          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3227          FG_COMM1,IERR)
3228        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
3229          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3230          FG_COMM1,IERR)
3231         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
3232          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3233          FG_COMM1,IERR)
3234        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
3235          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3236          FG_COMM1,IERR)
3237         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
3238          ivec_count(fg_rank1),&
3239          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3240          FG_COMM1,IERR)
3241         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
3242          ivec_count(fg_rank1),&
3243          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3244          FG_COMM1,IERR)
3245         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
3246          ivec_count(fg_rank1),&
3247          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3248          MPI_MAT2,FG_COMM1,IERR)
3249         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
3250          ivec_count(fg_rank1),&
3251          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3252          MPI_MAT2,FG_COMM1,IERR)
3253         endif
3254 #else
3255 ! Passes matrix info through the ring
3256       isend=fg_rank1
3257       irecv=fg_rank1-1
3258       if (irecv.lt.0) irecv=nfgtasks1-1
3259       iprev=irecv
3260       inext=fg_rank1+1
3261       if (inext.ge.nfgtasks1) inext=0
3262       do i=1,nfgtasks1-1
3263 !        write (iout,*) "isend",isend," irecv",irecv
3264 !        call flush(iout)
3265         lensend=lentyp(isend)
3266         lenrecv=lentyp(irecv)
3267 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3268 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3269 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
3270 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3271 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
3272 !        write (iout,*) "Gather ROTAT1"
3273 !        call flush(iout)
3274 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3275 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
3276 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3277 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
3278 !        write (iout,*) "Gather ROTAT2"
3279 !        call flush(iout)
3280         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
3281          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
3282          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
3283          iprev,4400+irecv,FG_COMM,status,IERR)
3284 !        write (iout,*) "Gather ROTAT_OLD"
3285 !        call flush(iout)
3286         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
3287          MPI_PRECOMP11(lensend),inext,5500+isend,&
3288          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
3289          iprev,5500+irecv,FG_COMM,status,IERR)
3290 !        write (iout,*) "Gather PRECOMP11"
3291 !        call flush(iout)
3292         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
3293          MPI_PRECOMP12(lensend),inext,6600+isend,&
3294          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
3295          iprev,6600+irecv,FG_COMM,status,IERR)
3296 !        write (iout,*) "Gather PRECOMP12"
3297 !        call flush(iout)
3298         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3299         then
3300         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
3301          MPI_ROTAT2(lensend),inext,7700+isend,&
3302          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
3303          iprev,7700+irecv,FG_COMM,status,IERR)
3304 !        write (iout,*) "Gather PRECOMP21"
3305 !        call flush(iout)
3306         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
3307          MPI_PRECOMP22(lensend),inext,8800+isend,&
3308          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
3309          iprev,8800+irecv,FG_COMM,status,IERR)
3310 !        write (iout,*) "Gather PRECOMP22"
3311 !        call flush(iout)
3312         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
3313          MPI_PRECOMP23(lensend),inext,9900+isend,&
3314          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
3315          MPI_PRECOMP23(lenrecv),&
3316          iprev,9900+irecv,FG_COMM,status,IERR)
3317 !        write (iout,*) "Gather PRECOMP23"
3318 !        call flush(iout)
3319         endif
3320         isend=irecv
3321         irecv=irecv-1
3322         if (irecv.lt.0) irecv=nfgtasks1-1
3323       enddo
3324 #endif
3325         time_gather=time_gather+MPI_Wtime()-time00
3326       endif
3327 #ifdef DEBUG
3328 !      if (fg_rank.eq.0) then
3329         write (iout,*) "Arrays UG and UGDER"
3330         do i=1,nres-1
3331           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3332            ((ug(l,k,i),l=1,2),k=1,2),&
3333            ((ugder(l,k,i),l=1,2),k=1,2)
3334         enddo
3335         write (iout,*) "Arrays UG2 and UG2DER"
3336         do i=1,nres-1
3337           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3338            ((ug2(l,k,i),l=1,2),k=1,2),&
3339            ((ug2der(l,k,i),l=1,2),k=1,2)
3340         enddo
3341         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3342         do i=1,nres-1
3343           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3344            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3345            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3346         enddo
3347         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3348         do i=1,nres-1
3349           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3350            costab(i),sintab(i),costab2(i),sintab2(i)
3351         enddo
3352         write (iout,*) "Array MUDER"
3353         do i=1,nres-1
3354           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3355         enddo
3356 !      endif
3357 #endif
3358 #endif
3359 !d      do i=1,nres
3360 !d        iti = itortyp(itype(i,1))
3361 !d        write (iout,*) i
3362 !d        do j=1,2
3363 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3364 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3365 !d        enddo
3366 !d      enddo
3367       return
3368       end subroutine set_matrices
3369 !-----------------------------------------------------------------------------
3370       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3371 !
3372 ! This subroutine calculates the average interaction energy and its gradient
3373 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
3374 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3375 ! The potential depends both on the distance of peptide-group centers and on
3376 ! the orientation of the CA-CA virtual bonds.
3377 !
3378       use comm_locel
3379 !      implicit real*8 (a-h,o-z)
3380 #ifdef MPI
3381       include 'mpif.h'
3382 #endif
3383 !      include 'DIMENSIONS'
3384 !      include 'COMMON.CONTROL'
3385 !      include 'COMMON.SETUP'
3386 !      include 'COMMON.IOUNITS'
3387 !      include 'COMMON.GEO'
3388 !      include 'COMMON.VAR'
3389 !      include 'COMMON.LOCAL'
3390 !      include 'COMMON.CHAIN'
3391 !      include 'COMMON.DERIV'
3392 !      include 'COMMON.INTERACT'
3393 !      include 'COMMON.CONTACTS'
3394 !      include 'COMMON.TORSION'
3395 !      include 'COMMON.VECTORS'
3396 !      include 'COMMON.FFIELD'
3397 !      include 'COMMON.TIME1'
3398       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
3399       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3400       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3401 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3402       real(kind=8),dimension(4) :: muij
3403 !el      integer :: num_conti,j1,j2
3404 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3405 !el        dz_normi,xmedi,ymedi,zmedi
3406
3407 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3408 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3409 !el          num_conti,j1,j2
3410
3411 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3412 #ifdef MOMENT
3413       real(kind=8) :: scal_el=1.0d0
3414 #else
3415       real(kind=8) :: scal_el=0.5d0
3416 #endif
3417 ! 12/13/98
3418 ! 13-go grudnia roku pamietnego...
3419       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3420                                              0.0d0,1.0d0,0.0d0,&
3421                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3422 !el local variables
3423       integer :: i,k,j,icont
3424       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
3425       real(kind=8) :: fac,t_eelecij,fracinbuf
3426
3427
3428 !d      write(iout,*) 'In EELEC'
3429 !        print *,"IN EELEC"
3430 !d      do i=1,nloctyp
3431 !d        write(iout,*) 'Type',i
3432 !d        write(iout,*) 'B1',B1(:,i)
3433 !d        write(iout,*) 'B2',B2(:,i)
3434 !d        write(iout,*) 'CC',CC(:,:,i)
3435 !d        write(iout,*) 'DD',DD(:,:,i)
3436 !d        write(iout,*) 'EE',EE(:,:,i)
3437 !d      enddo
3438 !d      call check_vecgrad
3439 !d      stop
3440 !      ees=0.0d0  !AS
3441 !      evdw1=0.0d0
3442 !      eel_loc=0.0d0
3443 !      eello_turn3=0.0d0
3444 !      eello_turn4=0.0d0
3445       t_eelecij=0.0d0
3446       ees=0.0D0
3447       evdw1=0.0D0
3448       eel_loc=0.0d0
3449       eello_turn3=0.0d0
3450       eello_turn4=0.0d0
3451 !
3452
3453       if (icheckgrad.eq.1) then
3454 !el
3455 !        do i=0,2*nres+2
3456 !          dc_norm(1,i)=0.0d0
3457 !          dc_norm(2,i)=0.0d0
3458 !          dc_norm(3,i)=0.0d0
3459 !        enddo
3460         do i=1,nres-1
3461           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3462           do k=1,3
3463             dc_norm(k,i)=dc(k,i)*fac
3464           enddo
3465 !          write (iout,*) 'i',i,' fac',fac
3466         enddo
3467       endif
3468 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3469 !        wturn6
3470       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3471           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3472           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3473 !        call vec_and_deriv
3474 #ifdef TIMING
3475         time01=MPI_Wtime()
3476 #endif
3477 !        print *, "before set matrices"
3478         call set_matrices
3479 !        print *, "after set matrices"
3480
3481 #ifdef TIMING
3482         time_mat=time_mat+MPI_Wtime()-time01
3483 #endif
3484       endif
3485 !       print *, "after set matrices"
3486 !d      do i=1,nres-1
3487 !d        write (iout,*) 'i=',i
3488 !d        do k=1,3
3489 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3490 !d        enddo
3491 !d        do k=1,3
3492 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3493 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3494 !d        enddo
3495 !d      enddo
3496       t_eelecij=0.0d0
3497       ees=0.0D0
3498       evdw1=0.0D0
3499       eel_loc=0.0d0
3500       eello_turn3=0.0d0
3501       eello_turn4=0.0d0
3502 !el      ind=0
3503       do i=1,nres
3504         num_cont_hb(i)=0
3505       enddo
3506 !d      print '(a)','Enter EELEC'
3507 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3508 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3509 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3510       do i=1,nres
3511         gel_loc_loc(i)=0.0d0
3512         gcorr_loc(i)=0.0d0
3513       enddo
3514 !
3515 !
3516 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3517 !
3518 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3519 !
3520
3521
3522 !        print *,"before iturn3 loop"
3523       do i=iturn3_start,iturn3_end
3524         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3525         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3526         dxi=dc(1,i)
3527         dyi=dc(2,i)
3528         dzi=dc(3,i)
3529         dx_normi=dc_norm(1,i)
3530         dy_normi=dc_norm(2,i)
3531         dz_normi=dc_norm(3,i)
3532         xmedi=c(1,i)+0.5d0*dxi
3533         ymedi=c(2,i)+0.5d0*dyi
3534         zmedi=c(3,i)+0.5d0*dzi
3535         call to_box(xmedi,ymedi,zmedi)
3536         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3537         num_conti=0
3538        call eelecij(i,i+2,ees,evdw1,eel_loc)
3539         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3540         num_cont_hb(i)=num_conti
3541       enddo
3542       do i=iturn4_start,iturn4_end
3543         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3544           .or. itype(i+3,1).eq.ntyp1 &
3545           .or. itype(i+4,1).eq.ntyp1) cycle
3546 !        print *,"before2",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3547         dxi=dc(1,i)
3548         dyi=dc(2,i)
3549         dzi=dc(3,i)
3550         dx_normi=dc_norm(1,i)
3551         dy_normi=dc_norm(2,i)
3552         dz_normi=dc_norm(3,i)
3553         xmedi=c(1,i)+0.5d0*dxi
3554         ymedi=c(2,i)+0.5d0*dyi
3555         zmedi=c(3,i)+0.5d0*dzi
3556         call to_box(xmedi,ymedi,zmedi)
3557         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3558         num_conti=num_cont_hb(i)
3559         call eelecij(i,i+3,ees,evdw1,eel_loc)
3560         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3561         call eturn4(i,eello_turn4)
3562 !        print *,"before",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3563         num_cont_hb(i)=num_conti
3564       enddo   ! i
3565 !
3566 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3567 !
3568 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3569 !      do i=iatel_s,iatel_e
3570 ! JPRDLC
3571        do icont=g_listpp_start,g_listpp_end
3572         i=newcontlistppi(icont)
3573         j=newcontlistppj(icont)
3574         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3575         dxi=dc(1,i)
3576         dyi=dc(2,i)
3577         dzi=dc(3,i)
3578         dx_normi=dc_norm(1,i)
3579         dy_normi=dc_norm(2,i)
3580         dz_normi=dc_norm(3,i)
3581         xmedi=c(1,i)+0.5d0*dxi
3582         ymedi=c(2,i)+0.5d0*dyi
3583         zmedi=c(3,i)+0.5d0*dzi
3584         call to_box(xmedi,ymedi,zmedi)
3585         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3586
3587 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3588         num_conti=num_cont_hb(i)
3589 !        do j=ielstart(i),ielend(i)
3590 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3591           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3592           call eelecij(i,j,ees,evdw1,eel_loc)
3593 !        enddo ! j
3594         num_cont_hb(i)=num_conti
3595       enddo   ! i
3596 !      write (iout,*) "Number of loop steps in EELEC:",ind
3597 !d      do i=1,nres
3598 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3599 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3600 !d      enddo
3601 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3602 !cc      eel_loc=eel_loc+eello_turn3
3603 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3604       return
3605       end subroutine eelec
3606 !-----------------------------------------------------------------------------
3607       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3608
3609       use comm_locel
3610 !      implicit real*8 (a-h,o-z)
3611 !      include 'DIMENSIONS'
3612 #ifdef MPI
3613       include "mpif.h"
3614 #endif
3615 !      include 'COMMON.CONTROL'
3616 !      include 'COMMON.IOUNITS'
3617 !      include 'COMMON.GEO'
3618 !      include 'COMMON.VAR'
3619 !      include 'COMMON.LOCAL'
3620 !      include 'COMMON.CHAIN'
3621 !      include 'COMMON.DERIV'
3622 !      include 'COMMON.INTERACT'
3623 !      include 'COMMON.CONTACTS'
3624 !      include 'COMMON.TORSION'
3625 !      include 'COMMON.VECTORS'
3626 !      include 'COMMON.FFIELD'
3627 !      include 'COMMON.TIME1'
3628       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3629       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3630       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3631 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3632       real(kind=8),dimension(4) :: muij
3633       real(kind=8) :: geel_loc_ij,geel_loc_ji
3634       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3635                     dist_temp, dist_init,rlocshield,fracinbuf
3636       integer xshift,yshift,zshift,ilist,iresshield
3637 !el      integer :: num_conti,j1,j2
3638 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3639 !el        dz_normi,xmedi,ymedi,zmedi
3640
3641 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3642 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3643 !el          num_conti,j1,j2
3644
3645 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3646 #ifdef MOMENT
3647       real(kind=8) :: scal_el=1.0d0
3648 #else
3649       real(kind=8) :: scal_el=0.5d0
3650 #endif
3651 ! 12/13/98
3652 ! 13-go grudnia roku pamietnego...
3653       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3654                                              0.0d0,1.0d0,0.0d0,&
3655                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3656 !      integer :: maxconts=nres/4
3657 !el local variables
3658       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3659       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3660       real(kind=8) ::  faclipij2, faclipij
3661       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3662       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3663                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3664                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3665                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3666                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3667                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3668                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3669                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3670 !      maxconts=nres/4
3671 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3672 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3673
3674 !          time00=MPI_Wtime()
3675 !d      write (iout,*) "eelecij",i,j
3676 !          ind=ind+1
3677           iteli=itel(i)
3678           itelj=itel(j)
3679           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3680           aaa=app(iteli,itelj)
3681           bbb=bpp(iteli,itelj)
3682           ael6i=ael6(iteli,itelj)
3683           ael3i=ael3(iteli,itelj)
3684           dxj=dc(1,j)
3685           dyj=dc(2,j)
3686           dzj=dc(3,j)
3687           dx_normj=dc_norm(1,j)
3688           dy_normj=dc_norm(2,j)
3689           dz_normj=dc_norm(3,j)
3690 !          xj=c(1,j)+0.5D0*dxj-xmedi
3691 !          yj=c(2,j)+0.5D0*dyj-ymedi
3692 !          zj=c(3,j)+0.5D0*dzj-zmedi
3693           xj=c(1,j)+0.5D0*dxj
3694           yj=c(2,j)+0.5D0*dyj
3695           zj=c(3,j)+0.5D0*dzj
3696
3697           call to_box(xj,yj,zj)
3698           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
3699           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
3700           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3701           xj=boxshift(xj-xmedi,boxxsize)
3702           yj=boxshift(yj-ymedi,boxysize)
3703           zj=boxshift(zj-zmedi,boxzsize)
3704
3705           rij=xj*xj+yj*yj+zj*zj
3706           rrmij=1.0D0/rij
3707           rij=dsqrt(rij)
3708 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3709             sss_ele_cut=sscale_ele(rij)
3710             sss_ele_grad=sscagrad_ele(rij)
3711 !             sss_ele_cut=1.0d0
3712 !             sss_ele_grad=0.0d0
3713 !            print *,sss_ele_cut,sss_ele_grad,&
3714 !            (rij),r_cut_ele,rlamb_ele
3715             if (sss_ele_cut.le.0.0) go to 128
3716
3717           rmij=1.0D0/rij
3718           r3ij=rrmij*rmij
3719           r6ij=r3ij*r3ij
3720           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3721           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3722           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3723           fac=cosa-3.0D0*cosb*cosg
3724           ev1=aaa*r6ij*r6ij
3725 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3726           if (j.eq.i+2) ev1=scal_el*ev1
3727           ev2=bbb*r6ij
3728           fac3=ael6i*r6ij
3729           fac4=ael3i*r3ij
3730           evdwij=ev1+ev2
3731           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3732           el2=fac4*fac
3733 !          eesij=el1+el2
3734           if (shield_mode.gt.0) then
3735 !C          fac_shield(i)=0.4
3736 !C          fac_shield(j)=0.6
3737           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3738           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3739           eesij=(el1+el2)
3740           ees=ees+eesij*sss_ele_cut
3741 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3742 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3743           else
3744           fac_shield(i)=1.0
3745           fac_shield(j)=1.0
3746           eesij=(el1+el2)
3747           ees=ees+eesij   &
3748             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3749 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3750           endif
3751
3752 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3753           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3754 !          ees=ees+eesij*sss_ele_cut
3755           evdw1=evdw1+evdwij*sss_ele_cut  &
3756            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3757 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3758 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3759 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3760 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3761
3762           if (energy_dec) then
3763 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3764 !                  'evdw1',i,j,evdwij,&
3765 !                  iteli,itelj,aaa,evdw1
3766               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3767               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3768           endif
3769 !
3770 ! Calculate contributions to the Cartesian gradient.
3771 !
3772 #ifdef SPLITELE
3773           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3774               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3775           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3776              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3777           fac1=fac
3778           erij(1)=xj*rmij
3779           erij(2)=yj*rmij
3780           erij(3)=zj*rmij
3781 !
3782 ! Radial derivatives. First process both termini of the fragment (i,j)
3783 !
3784           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3785           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3786           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3787            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3788           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3789             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3790
3791           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3792           (shield_mode.gt.0)) then
3793 !C          print *,i,j
3794           do ilist=1,ishield_list(i)
3795            iresshield=shield_list(ilist,i)
3796            do k=1,3
3797            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3798            *2.0*sss_ele_cut
3799            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3800                    rlocshield &
3801             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3802             *sss_ele_cut
3803             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3804            enddo
3805           enddo
3806           do ilist=1,ishield_list(j)
3807            iresshield=shield_list(ilist,j)
3808            do k=1,3
3809            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3810           *2.0*sss_ele_cut
3811            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3812                    rlocshield &
3813            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3814            *sss_ele_cut
3815            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3816            enddo
3817           enddo
3818           do k=1,3
3819             gshieldc(k,i)=gshieldc(k,i)+ &
3820                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3821            *sss_ele_cut
3822
3823             gshieldc(k,j)=gshieldc(k,j)+ &
3824                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3825            *sss_ele_cut
3826
3827             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3828                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3829            *sss_ele_cut
3830
3831             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3832                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3833            *sss_ele_cut
3834
3835            enddo
3836            endif
3837
3838
3839 !          do k=1,3
3840 !            ghalf=0.5D0*ggg(k)
3841 !            gelc(k,i)=gelc(k,i)+ghalf
3842 !            gelc(k,j)=gelc(k,j)+ghalf
3843 !          enddo
3844 ! 9/28/08 AL Gradient compotents will be summed only at the end
3845           do k=1,3
3846             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3847             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3848           enddo
3849             gelc_long(3,j)=gelc_long(3,j)+  &
3850           ssgradlipj*eesij/2.0d0*lipscale**2&
3851            *sss_ele_cut
3852
3853             gelc_long(3,i)=gelc_long(3,i)+  &
3854           ssgradlipi*eesij/2.0d0*lipscale**2&
3855            *sss_ele_cut
3856
3857
3858 !
3859 ! Loop over residues i+1 thru j-1.
3860 !
3861 !grad          do k=i+1,j-1
3862 !grad            do l=1,3
3863 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3864 !grad            enddo
3865 !grad          enddo
3866           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3867            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3868           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3869            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3870           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3871            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3872
3873 !          do k=1,3
3874 !            ghalf=0.5D0*ggg(k)
3875 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3876 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3877 !          enddo
3878 ! 9/28/08 AL Gradient compotents will be summed only at the end
3879           do k=1,3
3880             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3881             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3882           enddo
3883
3884 !C Lipidic part for scaling weight
3885            gvdwpp(3,j)=gvdwpp(3,j)+ &
3886           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3887            gvdwpp(3,i)=gvdwpp(3,i)+ &
3888           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3889 !! Loop over residues i+1 thru j-1.
3890 !
3891 !grad          do k=i+1,j-1
3892 !grad            do l=1,3
3893 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3894 !grad            enddo
3895 !grad          enddo
3896 #else
3897           facvdw=(ev1+evdwij)*sss_ele_cut &
3898            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3899
3900           facel=(el1+eesij)*sss_ele_cut
3901           fac1=fac
3902           fac=-3*rrmij*(facvdw+facvdw+facel)
3903           erij(1)=xj*rmij
3904           erij(2)=yj*rmij
3905           erij(3)=zj*rmij
3906 !
3907 ! Radial derivatives. First process both termini of the fragment (i,j)
3908 !
3909           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3910           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3911           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3912 !          do k=1,3
3913 !            ghalf=0.5D0*ggg(k)
3914 !            gelc(k,i)=gelc(k,i)+ghalf
3915 !            gelc(k,j)=gelc(k,j)+ghalf
3916 !          enddo
3917 ! 9/28/08 AL Gradient compotents will be summed only at the end
3918           do k=1,3
3919             gelc_long(k,j)=gelc(k,j)+ggg(k)
3920             gelc_long(k,i)=gelc(k,i)-ggg(k)
3921           enddo
3922 !
3923 ! Loop over residues i+1 thru j-1.
3924 !
3925 !grad          do k=i+1,j-1
3926 !grad            do l=1,3
3927 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3928 !grad            enddo
3929 !grad          enddo
3930 ! 9/28/08 AL Gradient compotents will be summed only at the end
3931           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3932            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3933           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3934            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3935           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3936            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3937
3938           do k=1,3
3939             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3940             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3941           enddo
3942            gvdwpp(3,j)=gvdwpp(3,j)+ &
3943           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3944            gvdwpp(3,i)=gvdwpp(3,i)+ &
3945           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3946
3947 #endif
3948 !
3949 ! Angular part
3950 !
3951           ecosa=2.0D0*fac3*fac1+fac4
3952           fac4=-3.0D0*fac4
3953           fac3=-6.0D0*fac3
3954           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3955           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3956           do k=1,3
3957             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3958             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3959           enddo
3960 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3961 !d   &          (dcosg(k),k=1,3)
3962           do k=1,3
3963             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3964              *fac_shield(i)**2*fac_shield(j)**2 &
3965              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3966
3967           enddo
3968 !          do k=1,3
3969 !            ghalf=0.5D0*ggg(k)
3970 !            gelc(k,i)=gelc(k,i)+ghalf
3971 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3972 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3973 !            gelc(k,j)=gelc(k,j)+ghalf
3974 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3975 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3976 !          enddo
3977 !grad          do k=i+1,j-1
3978 !grad            do l=1,3
3979 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3980 !grad            enddo
3981 !grad          enddo
3982           do k=1,3
3983             gelc(k,i)=gelc(k,i) &
3984                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3985                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3986                      *sss_ele_cut &
3987                      *fac_shield(i)**2*fac_shield(j)**2 &
3988                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3989
3990             gelc(k,j)=gelc(k,j) &
3991                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3992                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3993                      *sss_ele_cut  &
3994                      *fac_shield(i)**2*fac_shield(j)**2  &
3995                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3996
3997             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3998             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3999           enddo
4000
4001           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
4002               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
4003               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4004 !
4005 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4006 !   energy of a peptide unit is assumed in the form of a second-order
4007 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4008 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4009 !   are computed for EVERY pair of non-contiguous peptide groups.
4010 !
4011           if (j.lt.nres-1) then
4012             j1=j+1
4013             j2=j-1
4014           else
4015             j1=j-1
4016             j2=j-2
4017           endif
4018           kkk=0
4019           do k=1,2
4020             do l=1,2
4021               kkk=kkk+1
4022               muij(kkk)=mu(k,i)*mu(l,j)
4023 #ifdef NEWCORR
4024              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4025 !c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4026              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4027              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4028 !c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4029              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4030 #endif
4031
4032             enddo
4033           enddo
4034 !d         write (iout,*) 'EELEC: i',i,' j',j
4035 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
4036 !d          write(iout,*) 'muij',muij
4037           ury=scalar(uy(1,i),erij)
4038           urz=scalar(uz(1,i),erij)
4039           vry=scalar(uy(1,j),erij)
4040           vrz=scalar(uz(1,j),erij)
4041           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4042           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4043           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4044           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4045           fac=dsqrt(-ael6i)*r3ij
4046           a22=a22*fac
4047           a23=a23*fac
4048           a32=a32*fac
4049           a33=a33*fac
4050 !d          write (iout,'(4i5,4f10.5)')
4051 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
4052 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4053 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4054 !d     &      uy(:,j),uz(:,j)
4055 !d          write (iout,'(4f10.5)')
4056 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4057 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4058 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
4059 !d           write (iout,'(9f10.5/)')
4060 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4061 ! Derivatives of the elements of A in virtual-bond vectors
4062           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4063           do k=1,3
4064             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4065             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4066             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4067             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4068             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4069             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4070             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4071             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4072             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4073             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4074             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4075             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4076           enddo
4077 ! Compute radial contributions to the gradient
4078           facr=-3.0d0*rrmij
4079           a22der=a22*facr
4080           a23der=a23*facr
4081           a32der=a32*facr
4082           a33der=a33*facr
4083           agg(1,1)=a22der*xj
4084           agg(2,1)=a22der*yj
4085           agg(3,1)=a22der*zj
4086           agg(1,2)=a23der*xj
4087           agg(2,2)=a23der*yj
4088           agg(3,2)=a23der*zj
4089           agg(1,3)=a32der*xj
4090           agg(2,3)=a32der*yj
4091           agg(3,3)=a32der*zj
4092           agg(1,4)=a33der*xj
4093           agg(2,4)=a33der*yj
4094           agg(3,4)=a33der*zj
4095 ! Add the contributions coming from er
4096           fac3=-3.0d0*fac
4097           do k=1,3
4098             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4099             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4100             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4101             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4102           enddo
4103           do k=1,3
4104 ! Derivatives in DC(i)
4105 !grad            ghalf1=0.5d0*agg(k,1)
4106 !grad            ghalf2=0.5d0*agg(k,2)
4107 !grad            ghalf3=0.5d0*agg(k,3)
4108 !grad            ghalf4=0.5d0*agg(k,4)
4109             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
4110             -3.0d0*uryg(k,2)*vry)!+ghalf1
4111             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
4112             -3.0d0*uryg(k,2)*vrz)!+ghalf2
4113             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
4114             -3.0d0*urzg(k,2)*vry)!+ghalf3
4115             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
4116             -3.0d0*urzg(k,2)*vrz)!+ghalf4
4117 ! Derivatives in DC(i+1)
4118             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
4119             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4120             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
4121             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4122             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
4123             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4124             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
4125             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4126 ! Derivatives in DC(j)
4127             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
4128             -3.0d0*vryg(k,2)*ury)!+ghalf1
4129             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
4130             -3.0d0*vrzg(k,2)*ury)!+ghalf2
4131             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
4132             -3.0d0*vryg(k,2)*urz)!+ghalf3
4133             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
4134             -3.0d0*vrzg(k,2)*urz)!+ghalf4
4135 ! Derivatives in DC(j+1) or DC(nres-1)
4136             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
4137             -3.0d0*vryg(k,3)*ury)
4138             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
4139             -3.0d0*vrzg(k,3)*ury)
4140             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
4141             -3.0d0*vryg(k,3)*urz)
4142             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
4143             -3.0d0*vrzg(k,3)*urz)
4144 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
4145 !grad              do l=1,4
4146 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4147 !grad              enddo
4148 !grad            endif
4149           enddo
4150           acipa(1,1)=a22
4151           acipa(1,2)=a23
4152           acipa(2,1)=a32
4153           acipa(2,2)=a33
4154           a22=-a22
4155           a23=-a23
4156           do l=1,2
4157             do k=1,3
4158               agg(k,l)=-agg(k,l)
4159               aggi(k,l)=-aggi(k,l)
4160               aggi1(k,l)=-aggi1(k,l)
4161               aggj(k,l)=-aggj(k,l)
4162               aggj1(k,l)=-aggj1(k,l)
4163             enddo
4164           enddo
4165           if (j.lt.nres-1) then
4166             a22=-a22
4167             a32=-a32
4168             do l=1,3,2
4169               do k=1,3
4170                 agg(k,l)=-agg(k,l)
4171                 aggi(k,l)=-aggi(k,l)
4172                 aggi1(k,l)=-aggi1(k,l)
4173                 aggj(k,l)=-aggj(k,l)
4174                 aggj1(k,l)=-aggj1(k,l)
4175               enddo
4176             enddo
4177           else
4178             a22=-a22
4179             a23=-a23
4180             a32=-a32
4181             a33=-a33
4182             do l=1,4
4183               do k=1,3
4184                 agg(k,l)=-agg(k,l)
4185                 aggi(k,l)=-aggi(k,l)
4186                 aggi1(k,l)=-aggi1(k,l)
4187                 aggj(k,l)=-aggj(k,l)
4188                 aggj1(k,l)=-aggj1(k,l)
4189               enddo
4190             enddo
4191           endif
4192           ENDIF ! WCORR
4193           IF (wel_loc.gt.0.0d0) THEN
4194 ! Contribution to the local-electrostatic energy coming from the i-j pair
4195           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
4196            +a33*muij(4)
4197           if (shield_mode.eq.0) then
4198            fac_shield(i)=1.0
4199            fac_shield(j)=1.0
4200           endif
4201           eel_loc_ij=eel_loc_ij &
4202          *fac_shield(i)*fac_shield(j) &
4203          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4204 !C Now derivative over eel_loc
4205           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
4206          (shield_mode.gt.0)) then
4207 !C          print *,i,j
4208
4209           do ilist=1,ishield_list(i)
4210            iresshield=shield_list(ilist,i)
4211            do k=1,3
4212            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
4213                                                 /fac_shield(i)&
4214            *sss_ele_cut
4215            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4216                    rlocshield  &
4217           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
4218           *sss_ele_cut
4219
4220             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4221            +rlocshield
4222            enddo
4223           enddo
4224           do ilist=1,ishield_list(j)
4225            iresshield=shield_list(ilist,j)
4226            do k=1,3
4227            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
4228                                             /fac_shield(j)   &
4229             *sss_ele_cut
4230            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4231                    rlocshield  &
4232       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
4233        *sss_ele_cut
4234
4235            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4236                   +rlocshield
4237
4238            enddo
4239           enddo
4240
4241           do k=1,3
4242             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
4243                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4244                     *sss_ele_cut
4245             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
4246                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4247                     *sss_ele_cut
4248             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
4249                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4250                     *sss_ele_cut
4251             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
4252                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4253                     *sss_ele_cut
4254
4255            enddo
4256            endif
4257
4258 #ifdef NEWCORR
4259          geel_loc_ij=(a22*gmuij1(1)&
4260           +a23*gmuij1(2)&
4261           +a32*gmuij1(3)&
4262           +a33*gmuij1(4))&
4263          *fac_shield(i)*fac_shield(j)&
4264                     *sss_ele_cut     &
4265          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4266
4267
4268 !c         write(iout,*) "derivative over thatai"
4269 !c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4270 !c     &   a33*gmuij1(4)
4271          gloc(nphi+i,icg)=gloc(nphi+i,icg)+&
4272            geel_loc_ij*wel_loc
4273 !c         write(iout,*) "derivative over thatai-1"
4274 !c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4275 !c     &   a33*gmuij2(4)
4276          geel_loc_ij=&
4277           a22*gmuij2(1)&
4278           +a23*gmuij2(2)&
4279           +a32*gmuij2(3)&
4280           +a33*gmuij2(4)
4281          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+&
4282            geel_loc_ij*wel_loc&
4283          *fac_shield(i)*fac_shield(j)&
4284                     *sss_ele_cut &
4285          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4286
4287
4288 !c  Derivative over j residue
4289          geel_loc_ji=a22*gmuji1(1)&
4290           +a23*gmuji1(2)&
4291           +a32*gmuji1(3)&
4292           +a33*gmuji1(4)
4293 !c         write(iout,*) "derivative over thataj"
4294 !c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4295 !c     &   a33*gmuji1(4)
4296
4297         gloc(nphi+j,icg)=gloc(nphi+j,icg)+&
4298            geel_loc_ji*wel_loc&
4299          *fac_shield(i)*fac_shield(j)&
4300                     *sss_ele_cut &
4301          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4302
4303
4304          geel_loc_ji=&
4305           +a22*gmuji2(1)&
4306           +a23*gmuji2(2)&
4307           +a32*gmuji2(3)&
4308           +a33*gmuji2(4)
4309 !c         write(iout,*) "derivative over thataj-1"
4310 !c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4311 !c     &   a33*gmuji2(4)
4312          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+&
4313            geel_loc_ji*wel_loc&
4314          *fac_shield(i)*fac_shield(j)&
4315                     *sss_ele_cut &
4316          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4317
4318 #endif
4319
4320 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4321 !           eel_loc_ij=0.0
4322 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4323 !                  'eelloc',i,j,eel_loc_ij
4324           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,8f8.3)') &
4325                   'eelloc',i,j,eel_loc_ij,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4326 !           print *,"EELLOC",i,gel_loc_loc(i-1)
4327
4328 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4329 !          if (energy_dec) write (iout,*) "muij",muij
4330 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
4331
4332           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
4333 ! Partial derivatives in virtual-bond dihedral angles gamma
4334           if (i.gt.1) &
4335           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
4336                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
4337                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
4338                  *sss_ele_cut  &
4339           *fac_shield(i)*fac_shield(j) &
4340           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4341
4342           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
4343                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
4344                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
4345                  *sss_ele_cut &
4346           *fac_shield(i)*fac_shield(j) &
4347           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4348 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4349 !          do l=1,3
4350 !            ggg(1)=(agg(1,1)*muij(1)+ &
4351 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
4352 !            *sss_ele_cut &
4353 !             +eel_loc_ij*sss_ele_grad*rmij*xj
4354 !            ggg(2)=(agg(2,1)*muij(1)+ &
4355 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
4356 !            *sss_ele_cut &
4357 !             +eel_loc_ij*sss_ele_grad*rmij*yj
4358 !            ggg(3)=(agg(3,1)*muij(1)+ &
4359 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
4360 !            *sss_ele_cut &
4361 !             +eel_loc_ij*sss_ele_grad*rmij*zj
4362            xtemp(1)=xj
4363            xtemp(2)=yj
4364            xtemp(3)=zj
4365
4366            do l=1,3
4367             ggg(l)=(agg(l,1)*muij(1)+ &
4368                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
4369             *sss_ele_cut &
4370           *fac_shield(i)*fac_shield(j) &
4371           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
4372              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4373
4374
4375             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4376             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4377 !grad            ghalf=0.5d0*ggg(l)
4378 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4379 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4380           enddo
4381             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
4382           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
4383           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4384
4385             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
4386           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
4387           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4388
4389 !grad          do k=i+1,j2
4390 !grad            do l=1,3
4391 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4392 !grad            enddo
4393 !grad          enddo
4394 ! Remaining derivatives of eello
4395           do l=1,3
4396             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4397                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
4398             *sss_ele_cut &
4399           *fac_shield(i)*fac_shield(j) &
4400           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4401
4402 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4403             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4404                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4405             +aggi1(l,4)*muij(4))&
4406             *sss_ele_cut &
4407           *fac_shield(i)*fac_shield(j) &
4408           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4409
4410 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4411             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4412                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4413             *sss_ele_cut &
4414           *fac_shield(i)*fac_shield(j) &
4415           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4416
4417 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4418             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4419                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4420             +aggj1(l,4)*muij(4))&
4421             *sss_ele_cut &
4422           *fac_shield(i)*fac_shield(j) &
4423          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4424
4425 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4426           enddo
4427           ENDIF
4428 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4429 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4430           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4431              .and. num_conti.le.maxconts) then
4432 !            write (iout,*) i,j," entered corr"
4433 !
4434 ! Calculate the contact function. The ith column of the array JCONT will
4435 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4436 ! greater than I). The arrays FACONT and GACONT will contain the values of
4437 ! the contact function and its derivative.
4438 !           r0ij=1.02D0*rpp(iteli,itelj)
4439 !           r0ij=1.11D0*rpp(iteli,itelj)
4440             r0ij=2.20D0*rpp(iteli,itelj)
4441 !           r0ij=1.55D0*rpp(iteli,itelj)
4442             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4443 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4444             if (fcont.gt.0.0D0) then
4445               num_conti=num_conti+1
4446               if (num_conti.gt.maxconts) then
4447 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4448 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4449                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4450                                ' will skip next contacts for this conf.', num_conti
4451               else
4452                 jcont_hb(num_conti,i)=j
4453 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4454 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4455                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4456                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4457 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4458 !  terms.
4459                 d_cont(num_conti,i)=rij
4460 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4461 !     --- Electrostatic-interaction matrix ---
4462                 a_chuj(1,1,num_conti,i)=a22
4463                 a_chuj(1,2,num_conti,i)=a23
4464                 a_chuj(2,1,num_conti,i)=a32
4465                 a_chuj(2,2,num_conti,i)=a33
4466 !     --- Gradient of rij
4467                 do kkk=1,3
4468                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4469                 enddo
4470                 kkll=0
4471                 do k=1,2
4472                   do l=1,2
4473                     kkll=kkll+1
4474                     do m=1,3
4475                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4476                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4477                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4478                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4479                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4480                     enddo
4481                   enddo
4482                 enddo
4483                 ENDIF
4484                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4485 ! Calculate contact energies
4486                 cosa4=4.0D0*cosa
4487                 wij=cosa-3.0D0*cosb*cosg
4488                 cosbg1=cosb+cosg
4489                 cosbg2=cosb-cosg
4490 !               fac3=dsqrt(-ael6i)/r0ij**3
4491                 fac3=dsqrt(-ael6i)*r3ij
4492 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4493                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4494                 if (ees0tmp.gt.0) then
4495                   ees0pij=dsqrt(ees0tmp)
4496                 else
4497                   ees0pij=0
4498                 endif
4499                 if (shield_mode.eq.0) then
4500                 fac_shield(i)=1.0d0
4501                 fac_shield(j)=1.0d0
4502                 else
4503                 ees0plist(num_conti,i)=j
4504                 endif
4505 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4506                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4507                 if (ees0tmp.gt.0) then
4508                   ees0mij=dsqrt(ees0tmp)
4509                 else
4510                   ees0mij=0
4511                 endif
4512 !               ees0mij=0.0D0
4513                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4514                      *sss_ele_cut &
4515                      *fac_shield(i)*fac_shield(j)
4516 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4517
4518                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4519                      *sss_ele_cut &
4520                      *fac_shield(i)*fac_shield(j)
4521 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4522
4523 ! Diagnostics. Comment out or remove after debugging!
4524 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4525 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4526 !               ees0m(num_conti,i)=0.0D0
4527 ! End diagnostics.
4528 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4529 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4530 ! Angular derivatives of the contact function
4531                 ees0pij1=fac3/ees0pij
4532                 ees0mij1=fac3/ees0mij
4533                 fac3p=-3.0D0*fac3*rrmij
4534                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4535                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4536 !               ees0mij1=0.0D0
4537                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4538                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4539                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4540                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4541                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4542                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4543                 ecosap=ecosa1+ecosa2
4544                 ecosbp=ecosb1+ecosb2
4545                 ecosgp=ecosg1+ecosg2
4546                 ecosam=ecosa1-ecosa2
4547                 ecosbm=ecosb1-ecosb2
4548                 ecosgm=ecosg1-ecosg2
4549 ! Diagnostics
4550 !               ecosap=ecosa1
4551 !               ecosbp=ecosb1
4552 !               ecosgp=ecosg1
4553 !               ecosam=0.0D0
4554 !               ecosbm=0.0D0
4555 !               ecosgm=0.0D0
4556 ! End diagnostics
4557                 facont_hb(num_conti,i)=fcont
4558                 fprimcont=fprimcont/rij
4559 !d              facont_hb(num_conti,i)=1.0D0
4560 ! Following line is for diagnostics.
4561 !d              fprimcont=0.0D0
4562                 do k=1,3
4563                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4564                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4565                 enddo
4566                 do k=1,3
4567                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4568                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4569                 enddo
4570                 gggp(1)=gggp(1)+ees0pijp*xj &
4571                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4572                 gggp(2)=gggp(2)+ees0pijp*yj &
4573                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4574                 gggp(3)=gggp(3)+ees0pijp*zj &
4575                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4576
4577                 gggm(1)=gggm(1)+ees0mijp*xj &
4578                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4579
4580                 gggm(2)=gggm(2)+ees0mijp*yj &
4581                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4582
4583                 gggm(3)=gggm(3)+ees0mijp*zj &
4584                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4585
4586 ! Derivatives due to the contact function
4587                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4588                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4589                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4590                 do k=1,3
4591 !
4592 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4593 !          following the change of gradient-summation algorithm.
4594 !
4595 !grad                  ghalfp=0.5D0*gggp(k)
4596 !grad                  ghalfm=0.5D0*gggm(k)
4597                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4598                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4599                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4600                      *sss_ele_cut*fac_shield(i)*fac_shield(j) ! &
4601 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4602
4603
4604                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4605                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4606                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4607                      *sss_ele_cut*fac_shield(i)*fac_shield(j)!   &
4608 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4609
4610
4611                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4612                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4613 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4614
4615                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4616                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4617                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4618                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4619 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4620
4621                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4622                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4623                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4624                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4625 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4626
4627                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4628                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4629 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4630
4631                 enddo
4632 ! Diagnostics. Comment out or remove after debugging!
4633 !diag           do k=1,3
4634 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4635 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4636 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4637 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4638 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4639 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4640 !diag           enddo
4641               ENDIF ! wcorr
4642               endif  ! num_conti.le.maxconts
4643             endif  ! fcont.gt.0
4644           endif    ! j.gt.i+1
4645           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4646             do k=1,4
4647               do l=1,3
4648                 ghalf=0.5d0*agg(l,k)
4649                 aggi(l,k)=aggi(l,k)+ghalf
4650                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4651                 aggj(l,k)=aggj(l,k)+ghalf
4652               enddo
4653             enddo
4654             if (j.eq.nres-1 .and. i.lt.j-2) then
4655               do k=1,4
4656                 do l=1,3
4657                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4658                 enddo
4659               enddo
4660             endif
4661           endif
4662  128  continue
4663 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4664       return
4665       end subroutine eelecij
4666 !-----------------------------------------------------------------------------
4667       subroutine eturn3(i,eello_turn3)
4668 ! Third- and fourth-order contributions from turns
4669
4670       use comm_locel
4671 !      implicit real*8 (a-h,o-z)
4672 !      include 'DIMENSIONS'
4673 !      include 'COMMON.IOUNITS'
4674 !      include 'COMMON.GEO'
4675 !      include 'COMMON.VAR'
4676 !      include 'COMMON.LOCAL'
4677 !      include 'COMMON.CHAIN'
4678 !      include 'COMMON.DERIV'
4679 !      include 'COMMON.INTERACT'
4680 !      include 'COMMON.CONTACTS'
4681 !      include 'COMMON.TORSION'
4682 !      include 'COMMON.VECTORS'
4683 !      include 'COMMON.FFIELD'
4684 !      include 'COMMON.CONTROL'
4685       real(kind=8),dimension(3) :: ggg
4686       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4687         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,gpizda1,&
4688        gpizda2,auxgmat1,auxgmatt1,auxgmat2,auxgmatt2
4689
4690       real(kind=8),dimension(2) :: auxvec,auxvec1
4691 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4692       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4693 !el      integer :: num_conti,j1,j2
4694 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4695 !el        dz_normi,xmedi,ymedi,zmedi
4696
4697 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4698 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4699 !el         num_conti,j1,j2
4700 !el local variables
4701       integer :: i,j,l,k,ilist,iresshield
4702       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield,xj,yj
4703       xj=0.0d0
4704       yj=0.0d0
4705       j=i+2
4706 !      write (iout,*) "eturn3",i,j,j1,j2
4707           zj=(c(3,j)+c(3,j+1))/2.0d0
4708             call to_box(xj,yj,zj)
4709             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
4710
4711       a_temp(1,1)=a22
4712       a_temp(1,2)=a23
4713       a_temp(2,1)=a32
4714       a_temp(2,2)=a33
4715 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4716 !
4717 !               Third-order contributions
4718 !
4719 !                 (i+2)o----(i+3)
4720 !                      | |
4721 !                      | |
4722 !                 (i+1)o----i
4723 !
4724 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4725 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4726         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4727         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4728         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4729         call transpose2(auxmat(1,1),auxmat1(1,1))
4730         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4731         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4732         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4733         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4734         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4735
4736         if (shield_mode.eq.0) then
4737         fac_shield(i)=1.0d0
4738         fac_shield(j)=1.0d0
4739         endif
4740
4741         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4742          *fac_shield(i)*fac_shield(j)  &
4743          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4744         eello_t3= &
4745         0.5d0*(pizda(1,1)+pizda(2,2)) &
4746         *fac_shield(i)*fac_shield(j)
4747
4748         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4749                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4750 !C#ifdef NEWCORR
4751 !C Derivatives in theta
4752         gloc(nphi+i,icg)=gloc(nphi+i,icg) &
4753        +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3&
4754         *fac_shield(i)*fac_shield(j) &
4755         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4756
4757         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)&
4758        +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3&
4759         *fac_shield(i)*fac_shield(j) &
4760         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4761
4762
4763 !C#endif
4764
4765
4766
4767           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4768        (shield_mode.gt.0)) then
4769 !C          print *,i,j
4770
4771           do ilist=1,ishield_list(i)
4772            iresshield=shield_list(ilist,i)
4773            do k=1,3
4774            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4775            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4776                    rlocshield &
4777            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4778             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4779              +rlocshield
4780            enddo
4781           enddo
4782           do ilist=1,ishield_list(j)
4783            iresshield=shield_list(ilist,j)
4784            do k=1,3
4785            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4786            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4787                    rlocshield &
4788            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4789            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4790                   +rlocshield
4791
4792            enddo
4793           enddo
4794
4795           do k=1,3
4796             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4797                    grad_shield(k,i)*eello_t3/fac_shield(i)
4798             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4799                    grad_shield(k,j)*eello_t3/fac_shield(j)
4800             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4801                    grad_shield(k,i)*eello_t3/fac_shield(i)
4802             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4803                    grad_shield(k,j)*eello_t3/fac_shield(j)
4804            enddo
4805            endif
4806
4807 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4808 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4809 !d     &    ' eello_turn3_num',4*eello_turn3_num
4810 ! Derivatives in gamma(i)
4811         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4812         call transpose2(auxmat2(1,1),auxmat3(1,1))
4813         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4814         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4815           *fac_shield(i)*fac_shield(j)        &
4816           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4817 ! Derivatives in gamma(i+1)
4818         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4819         call transpose2(auxmat2(1,1),auxmat3(1,1))
4820         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4821         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4822           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4823           *fac_shield(i)*fac_shield(j)        &
4824           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4825
4826 ! Cartesian derivatives
4827         do l=1,3
4828 !            ghalf1=0.5d0*agg(l,1)
4829 !            ghalf2=0.5d0*agg(l,2)
4830 !            ghalf3=0.5d0*agg(l,3)
4831 !            ghalf4=0.5d0*agg(l,4)
4832           a_temp(1,1)=aggi(l,1)!+ghalf1
4833           a_temp(1,2)=aggi(l,2)!+ghalf2
4834           a_temp(2,1)=aggi(l,3)!+ghalf3
4835           a_temp(2,2)=aggi(l,4)!+ghalf4
4836           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4837           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4838             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4839           *fac_shield(i)*fac_shield(j)      &
4840           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4841
4842           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4843           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4844           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4845           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4846           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4847           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4848             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4849           *fac_shield(i)*fac_shield(j)        &
4850           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4851
4852           a_temp(1,1)=aggj(l,1)!+ghalf1
4853           a_temp(1,2)=aggj(l,2)!+ghalf2
4854           a_temp(2,1)=aggj(l,3)!+ghalf3
4855           a_temp(2,2)=aggj(l,4)!+ghalf4
4856           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4857           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4858             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4859           *fac_shield(i)*fac_shield(j)      &
4860           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4861
4862           a_temp(1,1)=aggj1(l,1)
4863           a_temp(1,2)=aggj1(l,2)
4864           a_temp(2,1)=aggj1(l,3)
4865           a_temp(2,2)=aggj1(l,4)
4866           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4867           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4868             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4869           *fac_shield(i)*fac_shield(j)        &
4870           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4871         enddo
4872          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4873           ssgradlipi*eello_t3/4.0d0*lipscale
4874          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4875           ssgradlipj*eello_t3/4.0d0*lipscale
4876          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4877           ssgradlipi*eello_t3/4.0d0*lipscale
4878          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4879           ssgradlipj*eello_t3/4.0d0*lipscale
4880
4881       return
4882       end subroutine eturn3
4883 !-----------------------------------------------------------------------------
4884       subroutine eturn4(i,eello_turn4)
4885 ! Third- and fourth-order contributions from turns
4886
4887       use comm_locel
4888 !      implicit real*8 (a-h,o-z)
4889 !      include 'DIMENSIONS'
4890 !      include 'COMMON.IOUNITS'
4891 !      include 'COMMON.GEO'
4892 !      include 'COMMON.VAR'
4893 !      include 'COMMON.LOCAL'
4894 !      include 'COMMON.CHAIN'
4895 !      include 'COMMON.DERIV'
4896 !      include 'COMMON.INTERACT'
4897 !      include 'COMMON.CONTACTS'
4898 !      include 'COMMON.TORSION'
4899 !      include 'COMMON.VECTORS'
4900 !      include 'COMMON.FFIELD'
4901 !      include 'COMMON.CONTROL'
4902       real(kind=8),dimension(3) :: ggg
4903       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4904         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,&
4905         gte1t,gte2t,gte3t,&
4906         gte1a,gtae3,gtae3e2, ae3gte2,&
4907         gtEpizda1,gtEpizda2,gtEpizda3
4908
4909       real(kind=8),dimension(2) :: auxvec,auxvec1,auxgEvec1,auxgEvec2,&
4910        auxgEvec3,auxgvec
4911
4912 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4913       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4914 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4915 !el        dz_normi,xmedi,ymedi,zmedi
4916 !el      integer :: num_conti,j1,j2
4917 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4918 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4919 !el          num_conti,j1,j2
4920 !el local variables
4921       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4922       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4923          rlocshield,gs23,gs32,gsE13,gs13,gs21,gsE31,gsEE1,gsEE2,gsEE3,xj,yj
4924       xj=0.0d0
4925       yj=0.0d0
4926       j=i+3
4927 !      if (j.ne.20) return
4928 !      print *,i,j,gshieldc_t4(2,j),gshieldc_t4(2,j+1)
4929 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4930 !
4931 !               Fourth-order contributions
4932 !
4933 !                 (i+3)o----(i+4)
4934 !                     /  |
4935 !               (i+2)o   |
4936 !                     \  |
4937 !                 (i+1)o----i
4938 !
4939 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4940 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4941 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4942           zj=(c(3,j)+c(3,j+1))/2.0d0
4943             call to_box(xj,yj,zj)
4944             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
4945
4946
4947         a_temp(1,1)=a22
4948         a_temp(1,2)=a23
4949         a_temp(2,1)=a32
4950         a_temp(2,2)=a33
4951         iti1=i+1
4952         iti2=i+2
4953         iti3=i+3
4954 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4955         call transpose2(EUg(1,1,i+1),e1t(1,1))
4956         call transpose2(Eug(1,1,i+2),e2t(1,1))
4957         call transpose2(Eug(1,1,i+3),e3t(1,1))
4958 !C Ematrix derivative in theta
4959         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4960         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4961         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4962
4963         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4964         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4965         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4966         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4967 !c       auxalary matrix of E i+1
4968         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4969         s1=scalar2(b1(1,iti2),auxvec(1))
4970 !c derivative of theta i+2 with constant i+3
4971         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4972 !c derivative of theta i+2 with constant i+2
4973         gs32=scalar2(b1(1,i+2),auxgvec(1))
4974 !c derivative of E matix in theta of i+1
4975         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4976
4977         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4978         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4979         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4980 !c auxilary matrix auxgvec of Ub2 with constant E matirx
4981         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4982 !c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4983         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4984         s2=scalar2(b1(1,i+1),auxvec(1))
4985 !c derivative of theta i+1 with constant i+3
4986         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4987 !c derivative of theta i+2 with constant i+1
4988         gs21=scalar2(b1(1,i+1),auxgvec(1))
4989 !c derivative of theta i+3 with constant i+1
4990         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4991
4992         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4993         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4994 !c ae3gte2 is derivative over i+2
4995         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4996
4997         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4998         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4999 !c i+2
5000         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5001 !c i+3
5002         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5003
5004         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5005         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5006         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5007         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5008         if (shield_mode.eq.0) then
5009         fac_shield(i)=1.0
5010         fac_shield(j)=1.0
5011         endif
5012
5013         eello_turn4=eello_turn4-(s1+s2+s3) &
5014         *fac_shield(i)*fac_shield(j)       &
5015         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5016         eello_t4=-(s1+s2+s3)  &
5017           *fac_shield(i)*fac_shield(j)
5018 !C Now derivative over shield:
5019           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
5020          (shield_mode.gt.0)) then
5021 !C          print *,i,j
5022
5023           do ilist=1,ishield_list(i)
5024            iresshield=shield_list(ilist,i)
5025            do k=1,3
5026            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5027 !           print *,"rlocshield",rlocshield,grad_shield_side(k,ilist,i),iresshield
5028            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5029                    rlocshield &
5030             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5031             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5032            +rlocshield
5033            enddo
5034           enddo
5035           do ilist=1,ishield_list(j)
5036            iresshield=shield_list(ilist,j)
5037            do k=1,3
5038 !           print *,"rlocshieldj",j,rlocshield,grad_shield_side(k,ilist,j),iresshield
5039            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5040            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5041                    rlocshield  &
5042            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5043            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5044                   +rlocshield
5045 !            print *,"after", gshieldc_t4(k,iresshield-1),iresshield-1,gshieldc_t4(k,iresshield)
5046
5047            enddo
5048           enddo
5049           do k=1,3
5050             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
5051                    grad_shield(k,i)*eello_t4/fac_shield(i)
5052             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
5053                    grad_shield(k,j)*eello_t4/fac_shield(j)
5054             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
5055                    grad_shield(k,i)*eello_t4/fac_shield(i)
5056             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
5057                    grad_shield(k,j)*eello_t4/fac_shield(j)
5058 !           print *,"gshieldc_t4(k,j+1)",j,gshieldc_t4(k,j+1)
5059            enddo
5060            endif
5061 #ifdef NEWCORR
5062         gloc(nphi+i,icg)=gloc(nphi+i,icg)&
5063                        -(gs13+gsE13+gsEE1)*wturn4&
5064        *fac_shield(i)*fac_shield(j)
5065         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)&
5066                          -(gs23+gs21+gsEE2)*wturn4&
5067        *fac_shield(i)*fac_shield(j)
5068
5069         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)&
5070                          -(gs32+gsE31+gsEE3)*wturn4&
5071        *fac_shield(i)*fac_shield(j)
5072
5073 !c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5074 !c     &   gs2
5075 #endif
5076         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5077            'eturn4',i,j,-(s1+s2+s3)
5078 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5079 !d     &    ' eello_turn4_num',8*eello_turn4_num
5080 ! Derivatives in gamma(i)
5081         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5082         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5083         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5084         s1=scalar2(b1(1,i+1),auxvec(1))
5085         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5086         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5087         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
5088        *fac_shield(i)*fac_shield(j)  &
5089        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5090
5091 ! Derivatives in gamma(i+1)
5092         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5093         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5094         s2=scalar2(b1(1,iti1),auxvec(1))
5095         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5096         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5097         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5098         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
5099        *fac_shield(i)*fac_shield(j)  &
5100        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5101
5102 ! Derivatives in gamma(i+2)
5103         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5104         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5105         s1=scalar2(b1(1,iti2),auxvec(1))
5106         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5107         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5108         s2=scalar2(b1(1,iti1),auxvec(1))
5109         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5110         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5111         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5112         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
5113        *fac_shield(i)*fac_shield(j)  &
5114        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5115
5116 ! Cartesian derivatives
5117 ! Derivatives of this turn contributions in DC(i+2)
5118         if (j.lt.nres-1) then
5119           do l=1,3
5120             a_temp(1,1)=agg(l,1)
5121             a_temp(1,2)=agg(l,2)
5122             a_temp(2,1)=agg(l,3)
5123             a_temp(2,2)=agg(l,4)
5124             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5125             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5126             s1=scalar2(b1(1,iti2),auxvec(1))
5127             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5128             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5129             s2=scalar2(b1(1,iti1),auxvec(1))
5130             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5131             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5132             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5133             ggg(l)=-(s1+s2+s3)
5134             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
5135        *fac_shield(i)*fac_shield(j)  &
5136        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5137
5138           enddo
5139         endif
5140 ! Remaining derivatives of this turn contribution
5141         do l=1,3
5142           a_temp(1,1)=aggi(l,1)
5143           a_temp(1,2)=aggi(l,2)
5144           a_temp(2,1)=aggi(l,3)
5145           a_temp(2,2)=aggi(l,4)
5146           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5147           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5148           s1=scalar2(b1(1,iti2),auxvec(1))
5149           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5150           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5151           s2=scalar2(b1(1,iti1),auxvec(1))
5152           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5153           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5154           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5155           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
5156          *fac_shield(i)*fac_shield(j)  &
5157          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5158
5159
5160           a_temp(1,1)=aggi1(l,1)
5161           a_temp(1,2)=aggi1(l,2)
5162           a_temp(2,1)=aggi1(l,3)
5163           a_temp(2,2)=aggi1(l,4)
5164           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5165           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5166           s1=scalar2(b1(1,iti2),auxvec(1))
5167           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5168           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5169           s2=scalar2(b1(1,iti1),auxvec(1))
5170           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5171           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5172           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5173           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
5174          *fac_shield(i)*fac_shield(j)  &
5175          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5176
5177
5178           a_temp(1,1)=aggj(l,1)
5179           a_temp(1,2)=aggj(l,2)
5180           a_temp(2,1)=aggj(l,3)
5181           a_temp(2,2)=aggj(l,4)
5182           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5183           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5184           s1=scalar2(b1(1,iti2),auxvec(1))
5185           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5186           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5187           s2=scalar2(b1(1,iti1),auxvec(1))
5188           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5189           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5190           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5191 !        if (j.lt.nres-1) then
5192           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
5193          *fac_shield(i)*fac_shield(j)  &
5194          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5195 !        endif
5196
5197           a_temp(1,1)=aggj1(l,1)
5198           a_temp(1,2)=aggj1(l,2)
5199           a_temp(2,1)=aggj1(l,3)
5200           a_temp(2,2)=aggj1(l,4)
5201           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5202           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5203           s1=scalar2(b1(1,iti2),auxvec(1))
5204           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5205           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5206           s2=scalar2(b1(1,iti1),auxvec(1))
5207           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5208           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5209           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5210 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5211 !        if (j.lt.nres-1) then
5212 !          print *,"juest before",j1, gcorr4_turn(l,j1)
5213           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
5214          *fac_shield(i)*fac_shield(j)  &
5215          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5216 !            if (shield_mode.gt.0) then
5217 !             print *,"juest after",j1, gcorr4_turn(l,j1),gshieldc_t4(k,j1),gshieldc_loc_t4(k,j1),gel_loc_turn4(i+2)
5218 !            else
5219 !             print *,"juest after",j1, gcorr4_turn(l,j1),gel_loc_turn4(i+2)
5220 !            endif
5221 !         endif
5222         enddo
5223          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
5224           ssgradlipi*eello_t4/4.0d0*lipscale
5225          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
5226           ssgradlipj*eello_t4/4.0d0*lipscale
5227          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
5228           ssgradlipi*eello_t4/4.0d0*lipscale
5229          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
5230           ssgradlipj*eello_t4/4.0d0*lipscale
5231
5232       return
5233       end subroutine eturn4
5234 !-----------------------------------------------------------------------------
5235       subroutine unormderiv(u,ugrad,unorm,ungrad)
5236 ! This subroutine computes the derivatives of a normalized vector u, given
5237 ! the derivatives computed without normalization conditions, ugrad. Returns
5238 ! ungrad.
5239 !      implicit none
5240       real(kind=8),dimension(3) :: u,vec
5241       real(kind=8),dimension(3,3) ::ugrad,ungrad
5242       real(kind=8) :: unorm      !,scalar
5243       integer :: i,j
5244 !      write (2,*) 'ugrad',ugrad
5245 !      write (2,*) 'u',u
5246       do i=1,3
5247         vec(i)=scalar(ugrad(1,i),u(1))
5248       enddo
5249 !      write (2,*) 'vec',vec
5250       do i=1,3
5251         do j=1,3
5252           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5253         enddo
5254       enddo
5255 !      write (2,*) 'ungrad',ungrad
5256       return
5257       end subroutine unormderiv
5258 !-----------------------------------------------------------------------------
5259       subroutine escp_soft_sphere(evdw2,evdw2_14)
5260 !
5261 ! This subroutine calculates the excluded-volume interaction energy between
5262 ! peptide-group centers and side chains and its gradient in virtual-bond and
5263 ! side-chain vectors.
5264 !
5265 !      implicit real*8 (a-h,o-z)
5266 !      include 'DIMENSIONS'
5267 !      include 'COMMON.GEO'
5268 !      include 'COMMON.VAR'
5269 !      include 'COMMON.LOCAL'
5270 !      include 'COMMON.CHAIN'
5271 !      include 'COMMON.DERIV'
5272 !      include 'COMMON.INTERACT'
5273 !      include 'COMMON.FFIELD'
5274 !      include 'COMMON.IOUNITS'
5275 !      include 'COMMON.CONTROL'
5276       real(kind=8),dimension(3) :: ggg
5277 !el local variables
5278       integer :: i,iint,j,k,iteli,itypj
5279       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
5280                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
5281
5282       evdw2=0.0D0
5283       evdw2_14=0.0d0
5284       r0_scp=4.5d0
5285 !d    print '(a)','Enter ESCP'
5286 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5287       do i=iatscp_s,iatscp_e
5288         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5289         iteli=itel(i)
5290         xi=0.5D0*(c(1,i)+c(1,i+1))
5291         yi=0.5D0*(c(2,i)+c(2,i+1))
5292         zi=0.5D0*(c(3,i)+c(3,i+1))
5293           call to_box(xi,yi,zi)
5294
5295         do iint=1,nscp_gr(i)
5296
5297         do j=iscpstart(i,iint),iscpend(i,iint)
5298           if (itype(j,1).eq.ntyp1) cycle
5299           itypj=iabs(itype(j,1))
5300 ! Uncomment following three lines for SC-p interactions
5301 !         xj=c(1,nres+j)-xi
5302 !         yj=c(2,nres+j)-yi
5303 !         zj=c(3,nres+j)-zi
5304 ! Uncomment following three lines for Ca-p interactions
5305           xj=c(1,j)-xi
5306           yj=c(2,j)-yi
5307           zj=c(3,j)-zi
5308           call to_box(xj,yj,zj)
5309           xj=boxshift(xj-xi,boxxsize)
5310           yj=boxshift(yj-yi,boxysize)
5311           zj=boxshift(zj-zi,boxzsize)
5312           rij=xj*xj+yj*yj+zj*zj
5313           r0ij=r0_scp
5314           r0ijsq=r0ij*r0ij
5315           if (rij.lt.r0ijsq) then
5316             evdwij=0.25d0*(rij-r0ijsq)**2
5317             fac=rij-r0ijsq
5318           else
5319             evdwij=0.0d0
5320             fac=0.0d0
5321           endif
5322           evdw2=evdw2+evdwij
5323 !
5324 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5325 !
5326           ggg(1)=xj*fac
5327           ggg(2)=yj*fac
5328           ggg(3)=zj*fac
5329 !grad          if (j.lt.i) then
5330 !d          write (iout,*) 'j<i'
5331 ! Uncomment following three lines for SC-p interactions
5332 !           do k=1,3
5333 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5334 !           enddo
5335 !grad          else
5336 !d          write (iout,*) 'j>i'
5337 !grad            do k=1,3
5338 !grad              ggg(k)=-ggg(k)
5339 ! Uncomment following line for SC-p interactions
5340 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5341 !grad            enddo
5342 !grad          endif
5343 !grad          do k=1,3
5344 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5345 !grad          enddo
5346 !grad          kstart=min0(i+1,j)
5347 !grad          kend=max0(i-1,j-1)
5348 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5349 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5350 !grad          do k=kstart,kend
5351 !grad            do l=1,3
5352 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5353 !grad            enddo
5354 !grad          enddo
5355           do k=1,3
5356             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5357             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5358           enddo
5359         enddo
5360
5361         enddo ! iint
5362       enddo ! i
5363       return
5364       end subroutine escp_soft_sphere
5365 !-----------------------------------------------------------------------------
5366       subroutine escp(evdw2,evdw2_14)
5367 !
5368 ! This subroutine calculates the excluded-volume interaction energy between
5369 ! peptide-group centers and side chains and its gradient in virtual-bond and
5370 ! side-chain vectors.
5371 !
5372 !      implicit real*8 (a-h,o-z)
5373 !      include 'DIMENSIONS'
5374 !      include 'COMMON.GEO'
5375 !      include 'COMMON.VAR'
5376 !      include 'COMMON.LOCAL'
5377 !      include 'COMMON.CHAIN'
5378 !      include 'COMMON.DERIV'
5379 !      include 'COMMON.INTERACT'
5380 !      include 'COMMON.FFIELD'
5381 !      include 'COMMON.IOUNITS'
5382 !      include 'COMMON.CONTROL'
5383       real(kind=8),dimension(3) :: ggg
5384 !el local variables
5385       integer :: i,iint,j,k,iteli,itypj,subchap,icont
5386       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
5387                    e1,e2,evdwij,rij
5388       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
5389                     dist_temp, dist_init
5390       integer xshift,yshift,zshift
5391
5392       evdw2=0.0D0
5393       evdw2_14=0.0d0
5394 !d    print '(a)','Enter ESCP'
5395 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5396 !      do i=iatscp_s,iatscp_e
5397        do icont=g_listscp_start,g_listscp_end
5398         i=newcontlistscpi(icont)
5399         j=newcontlistscpj(icont)
5400         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5401         iteli=itel(i)
5402         xi=0.5D0*(c(1,i)+c(1,i+1))
5403         yi=0.5D0*(c(2,i)+c(2,i+1))
5404         zi=0.5D0*(c(3,i)+c(3,i+1))
5405         call to_box(xi,yi,zi)
5406
5407 !        do iint=1,nscp_gr(i)
5408
5409 !        do j=iscpstart(i,iint),iscpend(i,iint)
5410           itypj=iabs(itype(j,1))
5411           if (itypj.eq.ntyp1) cycle
5412 ! Uncomment following three lines for SC-p interactions
5413 !         xj=c(1,nres+j)-xi
5414 !         yj=c(2,nres+j)-yi
5415 !         zj=c(3,nres+j)-zi
5416 ! Uncomment following three lines for Ca-p interactions
5417 !          xj=c(1,j)-xi
5418 !          yj=c(2,j)-yi
5419 !          zj=c(3,j)-zi
5420           xj=c(1,j)
5421           yj=c(2,j)
5422           zj=c(3,j)
5423
5424           call to_box(xj,yj,zj)
5425           xj=boxshift(xj-xi,boxxsize)
5426           yj=boxshift(yj-yi,boxysize)
5427           zj=boxshift(zj-zi,boxzsize)
5428
5429           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5430           rij=dsqrt(1.0d0/rrij)
5431             sss_ele_cut=sscale_ele(rij)
5432             sss_ele_grad=sscagrad_ele(rij)
5433 !            print *,sss_ele_cut,sss_ele_grad,&
5434 !            (rij),r_cut_ele,rlamb_ele
5435             if (sss_ele_cut.le.0.0) cycle
5436           fac=rrij**expon2
5437           e1=fac*fac*aad(itypj,iteli)
5438           e2=fac*bad(itypj,iteli)
5439           if (iabs(j-i) .le. 2) then
5440             e1=scal14*e1
5441             e2=scal14*e2
5442             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5443           endif
5444           evdwij=e1+e2
5445           evdw2=evdw2+evdwij*sss_ele_cut
5446 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5447 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5448           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5449              'evdw2',i,j,evdwij
5450 !
5451 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5452 !
5453           fac=-(evdwij+e1)*rrij*sss_ele_cut
5454           fac=fac+evdwij*sss_ele_grad/rij/expon
5455           ggg(1)=xj*fac
5456           ggg(2)=yj*fac
5457           ggg(3)=zj*fac
5458 !grad          if (j.lt.i) then
5459 !d          write (iout,*) 'j<i'
5460 ! Uncomment following three lines for SC-p interactions
5461 !           do k=1,3
5462 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5463 !           enddo
5464 !grad          else
5465 !d          write (iout,*) 'j>i'
5466 !grad            do k=1,3
5467 !grad              ggg(k)=-ggg(k)
5468 ! Uncomment following line for SC-p interactions
5469 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5470 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5471 !grad            enddo
5472 !grad          endif
5473 !grad          do k=1,3
5474 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5475 !grad          enddo
5476 !grad          kstart=min0(i+1,j)
5477 !grad          kend=max0(i-1,j-1)
5478 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5479 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5480 !grad          do k=kstart,kend
5481 !grad            do l=1,3
5482 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5483 !grad            enddo
5484 !grad          enddo
5485           do k=1,3
5486             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5487             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5488           enddo
5489 !        enddo
5490
5491 !        enddo ! iint
5492       enddo ! i
5493       do i=1,nct
5494         do j=1,3
5495           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5496           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5497           gradx_scp(j,i)=expon*gradx_scp(j,i)
5498         enddo
5499       enddo
5500 !******************************************************************************
5501 !
5502 !                              N O T E !!!
5503 !
5504 ! To save time the factor EXPON has been extracted from ALL components
5505 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5506 ! use!
5507 !
5508 !******************************************************************************
5509       return
5510       end subroutine escp
5511 !-----------------------------------------------------------------------------
5512       subroutine edis(ehpb)
5513 !
5514 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5515 !
5516 !      implicit real*8 (a-h,o-z)
5517 !      include 'DIMENSIONS'
5518 !      include 'COMMON.SBRIDGE'
5519 !      include 'COMMON.CHAIN'
5520 !      include 'COMMON.DERIV'
5521 !      include 'COMMON.VAR'
5522 !      include 'COMMON.INTERACT'
5523 !      include 'COMMON.IOUNITS'
5524       real(kind=8),dimension(3) :: ggg
5525 !el local variables
5526       integer :: i,j,ii,jj,iii,jjj,k
5527       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5528
5529       ehpb=0.0D0
5530 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5531 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5532       if (link_end.eq.0) return
5533       do i=link_start,link_end
5534 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5535 ! CA-CA distance used in regularization of structure.
5536         ii=ihpb(i)
5537         jj=jhpb(i)
5538 ! iii and jjj point to the residues for which the distance is assigned.
5539         if (ii.gt.nres) then
5540           iii=ii-nres
5541           jjj=jj-nres
5542         else
5543           iii=ii
5544           jjj=jj
5545         endif
5546 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5547 !     &    dhpb(i),dhpb1(i),forcon(i)
5548 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5549 !    distance and angle dependent SS bond potential.
5550 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5551 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5552         if (.not.dyn_ss .and. i.le.nss) then
5553 ! 15/02/13 CC dynamic SSbond - additional check
5554          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5555         iabs(itype(jjj,1)).eq.1) then
5556           call ssbond_ene(iii,jjj,eij)
5557           ehpb=ehpb+2*eij
5558 !          write (iout,*) "eij",eij,iii,jjj
5559          endif
5560         else if (ii.gt.nres .and. jj.gt.nres) then
5561 !c Restraints from contact prediction
5562           dd=dist(ii,jj)
5563           if (constr_dist.eq.11) then
5564             ehpb=ehpb+fordepth(i)**4.0d0 &
5565                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5566             fac=fordepth(i)**4.0d0 &
5567                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5568           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5569             ehpb,fordepth(i),dd
5570            else
5571           if (dhpb1(i).gt.0.0d0) then
5572             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5573             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5574 !c            write (iout,*) "beta nmr",
5575 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5576           else
5577             dd=dist(ii,jj)
5578             rdis=dd-dhpb(i)
5579 !C Get the force constant corresponding to this distance.
5580             waga=forcon(i)
5581 !C Calculate the contribution to energy.
5582             ehpb=ehpb+waga*rdis*rdis
5583 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5584 !C
5585 !C Evaluate gradient.
5586 !C
5587             fac=waga*rdis/dd
5588           endif
5589           endif
5590           do j=1,3
5591             ggg(j)=fac*(c(j,jj)-c(j,ii))
5592           enddo
5593           do j=1,3
5594             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5595             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5596           enddo
5597           do k=1,3
5598             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5599             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5600           enddo
5601         else
5602           dd=dist(ii,jj)
5603           if (constr_dist.eq.11) then
5604             ehpb=ehpb+fordepth(i)**4.0d0 &
5605                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5606             fac=fordepth(i)**4.0d0 &
5607                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5608           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5609          ehpb,fordepth(i),dd
5610            else
5611           if (dhpb1(i).gt.0.0d0) then
5612             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5613             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5614 !c            write (iout,*) "alph nmr",
5615 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5616           else
5617             rdis=dd-dhpb(i)
5618 !C Get the force constant corresponding to this distance.
5619             waga=forcon(i)
5620 !C Calculate the contribution to energy.
5621             ehpb=ehpb+waga*rdis*rdis
5622 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5623 !C
5624 !C Evaluate gradient.
5625 !C
5626             fac=waga*rdis/dd
5627           endif
5628           endif
5629
5630             do j=1,3
5631               ggg(j)=fac*(c(j,jj)-c(j,ii))
5632             enddo
5633 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5634 !C If this is a SC-SC distance, we need to calculate the contributions to the
5635 !C Cartesian gradient in the SC vectors (ghpbx).
5636           if (iii.lt.ii) then
5637           do j=1,3
5638             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5639             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5640           enddo
5641           endif
5642 !cgrad        do j=iii,jjj-1
5643 !cgrad          do k=1,3
5644 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5645 !cgrad          enddo
5646 !cgrad        enddo
5647           do k=1,3
5648             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5649             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5650           enddo
5651         endif
5652       enddo
5653       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5654
5655       return
5656       end subroutine edis
5657 !-----------------------------------------------------------------------------
5658       subroutine ssbond_ene(i,j,eij)
5659 !
5660 ! Calculate the distance and angle dependent SS-bond potential energy
5661 ! using a free-energy function derived based on RHF/6-31G** ab initio
5662 ! calculations of diethyl disulfide.
5663 !
5664 ! A. Liwo and U. Kozlowska, 11/24/03
5665 !
5666 !      implicit real*8 (a-h,o-z)
5667 !      include 'DIMENSIONS'
5668 !      include 'COMMON.SBRIDGE'
5669 !      include 'COMMON.CHAIN'
5670 !      include 'COMMON.DERIV'
5671 !      include 'COMMON.LOCAL'
5672 !      include 'COMMON.INTERACT'
5673 !      include 'COMMON.VAR'
5674 !      include 'COMMON.IOUNITS'
5675       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5676 !el local variables
5677       integer :: i,j,itypi,itypj,k
5678       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5679                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5680                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5681                    cosphi,ggk
5682
5683       itypi=iabs(itype(i,1))
5684       xi=c(1,nres+i)
5685       yi=c(2,nres+i)
5686       zi=c(3,nres+i)
5687           call to_box(xi,yi,zi)
5688
5689       dxi=dc_norm(1,nres+i)
5690       dyi=dc_norm(2,nres+i)
5691       dzi=dc_norm(3,nres+i)
5692 !      dsci_inv=dsc_inv(itypi)
5693       dsci_inv=vbld_inv(nres+i)
5694       itypj=iabs(itype(j,1))
5695 !      dscj_inv=dsc_inv(itypj)
5696       dscj_inv=vbld_inv(nres+j)
5697       xj=c(1,nres+j)
5698       yj=c(2,nres+j)
5699       zj=c(3,nres+j)
5700           call to_box(xj,yj,zj)
5701       xj=boxshift(xj-xi,boxxsize)
5702       yj=boxshift(yj-yi,boxysize)
5703       zj=boxshift(zj-zi,boxzsize)
5704       dxj=dc_norm(1,nres+j)
5705       dyj=dc_norm(2,nres+j)
5706       dzj=dc_norm(3,nres+j)
5707       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5708       rij=dsqrt(rrij)
5709       erij(1)=xj*rij
5710       erij(2)=yj*rij
5711       erij(3)=zj*rij
5712       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5713       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5714       om12=dxi*dxj+dyi*dyj+dzi*dzj
5715       do k=1,3
5716         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5717         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5718       enddo
5719       rij=1.0d0/rij
5720       deltad=rij-d0cm
5721       deltat1=1.0d0-om1
5722       deltat2=1.0d0+om2
5723       deltat12=om2-om1+2.0d0
5724       cosphi=om12-om1*om2
5725       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5726         +akct*deltad*deltat12 &
5727         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5728 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth, &
5729 !       " akct",akct," deltad",deltad," deltat",deltat1,deltat2, &
5730 !       " deltat12",deltat12," eij",eij
5731       ed=2*akcm*deltad+akct*deltat12
5732       pom1=akct*deltad
5733       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5734       eom1=-2*akth*deltat1-pom1-om2*pom2
5735       eom2= 2*akth*deltat2+pom1-om1*pom2
5736       eom12=pom2
5737       do k=1,3
5738         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5739         ghpbx(k,i)=ghpbx(k,i)-ggk &
5740                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5741                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5742         ghpbx(k,j)=ghpbx(k,j)+ggk &
5743                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5744                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5745         ghpbc(k,i)=ghpbc(k,i)-ggk
5746         ghpbc(k,j)=ghpbc(k,j)+ggk
5747       enddo
5748 !
5749 ! Calculate the components of the gradient in DC and X
5750 !
5751 !grad      do k=i,j-1
5752 !grad        do l=1,3
5753 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5754 !grad        enddo
5755 !grad      enddo
5756       return
5757       end subroutine ssbond_ene
5758 !-----------------------------------------------------------------------------
5759       subroutine ebond(estr)
5760 !
5761 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5762 !
5763 !      implicit real*8 (a-h,o-z)
5764 !      include 'DIMENSIONS'
5765 !      include 'COMMON.LOCAL'
5766 !      include 'COMMON.GEO'
5767 !      include 'COMMON.INTERACT'
5768 !      include 'COMMON.DERIV'
5769 !      include 'COMMON.VAR'
5770 !      include 'COMMON.CHAIN'
5771 !      include 'COMMON.IOUNITS'
5772 !      include 'COMMON.NAMES'
5773 !      include 'COMMON.FFIELD'
5774 !      include 'COMMON.CONTROL'
5775 !      include 'COMMON.SETUP'
5776       real(kind=8),dimension(3) :: u,ud
5777 !el local variables
5778       integer :: i,j,iti,nbi,k
5779       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5780                    uprod1,uprod2
5781
5782       estr=0.0d0
5783       estr1=0.0d0
5784 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5785 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5786
5787       do i=ibondp_start,ibondp_end
5788         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5789         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5790 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5791 !C          do j=1,3
5792 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5793 !C            *dc(j,i-1)/vbld(i)
5794 !C          enddo
5795 !C          if (energy_dec) write(iout,*) &
5796 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5797         diff = vbld(i)-vbldpDUM
5798         else
5799         diff = vbld(i)-vbldp0
5800         endif
5801         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5802            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5803         estr=estr+diff*diff
5804         do j=1,3
5805           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5806         enddo
5807 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5808 !        endif
5809       enddo
5810       estr=0.5d0*AKP*estr+estr1
5811 !      print *,"estr_bb",estr,AKP
5812 !
5813 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5814 !
5815       do i=ibond_start,ibond_end
5816         iti=iabs(itype(i,1))
5817         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5818         if (iti.ne.10 .and. iti.ne.ntyp1) then
5819           nbi=nbondterm(iti)
5820           if (nbi.eq.1) then
5821             diff=vbld(i+nres)-vbldsc0(1,iti)
5822             if (energy_dec) write (iout,*) &
5823             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5824             AKSC(1,iti),AKSC(1,iti)*diff*diff
5825             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5826 !            print *,"estr_sc",estr
5827             do j=1,3
5828               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5829             enddo
5830           else
5831             do j=1,nbi
5832               diff=vbld(i+nres)-vbldsc0(j,iti)
5833               ud(j)=aksc(j,iti)*diff
5834               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5835             enddo
5836             uprod=u(1)
5837             do j=2,nbi
5838               uprod=uprod*u(j)
5839             enddo
5840             usum=0.0d0
5841             usumsqder=0.0d0
5842             do j=1,nbi
5843               uprod1=1.0d0
5844               uprod2=1.0d0
5845               do k=1,nbi
5846                 if (k.ne.j) then
5847                   uprod1=uprod1*u(k)
5848                   uprod2=uprod2*u(k)*u(k)
5849                 endif
5850               enddo
5851               usum=usum+uprod1
5852               usumsqder=usumsqder+ud(j)*uprod2
5853             enddo
5854             estr=estr+uprod/usum
5855 !            print *,"estr_sc",estr,i
5856
5857              if (energy_dec) write (iout,*) &
5858             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5859             AKSC(1,iti),uprod/usum
5860             do j=1,3
5861              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5862             enddo
5863           endif
5864         endif
5865       enddo
5866       return
5867       end subroutine ebond
5868 #ifdef CRYST_THETA
5869 !-----------------------------------------------------------------------------
5870       subroutine ebend(etheta)
5871 !
5872 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5873 ! angles gamma and its derivatives in consecutive thetas and gammas.
5874 !
5875       use comm_calcthet
5876 !      implicit real*8 (a-h,o-z)
5877 !      include 'DIMENSIONS'
5878 !      include 'COMMON.LOCAL'
5879 !      include 'COMMON.GEO'
5880 !      include 'COMMON.INTERACT'
5881 !      include 'COMMON.DERIV'
5882 !      include 'COMMON.VAR'
5883 !      include 'COMMON.CHAIN'
5884 !      include 'COMMON.IOUNITS'
5885 !      include 'COMMON.NAMES'
5886 !      include 'COMMON.FFIELD'
5887 !      include 'COMMON.CONTROL'
5888 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5889 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5890 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5891 !el      integer :: it
5892 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5893 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5894 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5895 !el local variables
5896       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5897        ichir21,ichir22
5898       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5899        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5900        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5901       real(kind=8),dimension(2) :: y,z
5902
5903       delta=0.02d0*pi
5904 !      time11=dexp(-2*time)
5905 !      time12=1.0d0
5906       etheta=0.0D0
5907 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5908       do i=ithet_start,ithet_end
5909         if (itype(i-1,1).eq.ntyp1) cycle
5910 ! Zero the energy function and its derivative at 0 or pi.
5911         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5912         it=itype(i-1,1)
5913         ichir1=isign(1,itype(i-2,1))
5914         ichir2=isign(1,itype(i,1))
5915          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
5916          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
5917          if (itype(i-1,1).eq.10) then
5918           itype1=isign(10,itype(i-2,1))
5919           ichir11=isign(1,itype(i-2,1))
5920           ichir12=isign(1,itype(i-2,1))
5921           itype2=isign(10,itype(i,1))
5922           ichir21=isign(1,itype(i,1))
5923           ichir22=isign(1,itype(i,1))
5924          endif
5925
5926         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
5927 #ifdef OSF
5928           phii=phi(i)
5929           if (phii.ne.phii) phii=150.0
5930 #else
5931           phii=phi(i)
5932 #endif
5933           y(1)=dcos(phii)
5934           y(2)=dsin(phii)
5935         else
5936           y(1)=0.0D0
5937           y(2)=0.0D0
5938         endif
5939         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
5940 #ifdef OSF
5941           phii1=phi(i+1)
5942           if (phii1.ne.phii1) phii1=150.0
5943           phii1=pinorm(phii1)
5944           z(1)=cos(phii1)
5945 #else
5946           phii1=phi(i+1)
5947           z(1)=dcos(phii1)
5948 #endif
5949           z(2)=dsin(phii1)
5950         else
5951           z(1)=0.0D0
5952           z(2)=0.0D0
5953         endif
5954 ! Calculate the "mean" value of theta from the part of the distribution
5955 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5956 ! In following comments this theta will be referred to as t_c.
5957         thet_pred_mean=0.0d0
5958         do k=1,2
5959             athetk=athet(k,it,ichir1,ichir2)
5960             bthetk=bthet(k,it,ichir1,ichir2)
5961           if (it.eq.10) then
5962              athetk=athet(k,itype1,ichir11,ichir12)
5963              bthetk=bthet(k,itype2,ichir21,ichir22)
5964           endif
5965          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5966         enddo
5967         dthett=thet_pred_mean*ssd
5968         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5969 ! Derivatives of the "mean" values in gamma1 and gamma2.
5970         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5971                +athet(2,it,ichir1,ichir2)*y(1))*ss
5972         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5973                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5974          if (it.eq.10) then
5975         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5976              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5977         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5978                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5979          endif
5980         if (theta(i).gt.pi-delta) then
5981           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5982                E_tc0)
5983           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5984           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5985           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5986               E_theta)
5987           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
5988               E_tc)
5989         else if (theta(i).lt.delta) then
5990           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5991           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5992           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
5993               E_theta)
5994           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5995           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
5996               E_tc)
5997         else
5998           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
5999               E_theta,E_tc)
6000         endif
6001         etheta=etheta+ethetai
6002         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6003             'ebend',i,ethetai
6004         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6005         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6006         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
6007       enddo
6008 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6009
6010 ! Ufff.... We've done all this!!!
6011       return
6012       end subroutine ebend
6013 !-----------------------------------------------------------------------------
6014       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
6015
6016       use comm_calcthet
6017 !      implicit real*8 (a-h,o-z)
6018 !      include 'DIMENSIONS'
6019 !      include 'COMMON.LOCAL'
6020 !      include 'COMMON.IOUNITS'
6021 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6022 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6023 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6024       integer :: i,j,k
6025       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
6026 !el      integer :: it
6027 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6028 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6029 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6030 !el local variables
6031       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
6032        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6033
6034 ! Calculate the contributions to both Gaussian lobes.
6035 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6036 ! The "polynomial part" of the "standard deviation" of this part of
6037 ! the distribution.
6038         sig=polthet(3,it)
6039         do j=2,0,-1
6040           sig=sig*thet_pred_mean+polthet(j,it)
6041         enddo
6042 ! Derivative of the "interior part" of the "standard deviation of the"
6043 ! gamma-dependent Gaussian lobe in t_c.
6044         sigtc=3*polthet(3,it)
6045         do j=2,1,-1
6046           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6047         enddo
6048         sigtc=sig*sigtc
6049 ! Set the parameters of both Gaussian lobes of the distribution.
6050 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6051         fac=sig*sig+sigc0(it)
6052         sigcsq=fac+fac
6053         sigc=1.0D0/sigcsq
6054 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6055         sigsqtc=-4.0D0*sigcsq*sigtc
6056 !       print *,i,sig,sigtc,sigsqtc
6057 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
6058         sigtc=-sigtc/(fac*fac)
6059 ! Following variable is sigma(t_c)**(-2)
6060         sigcsq=sigcsq*sigcsq
6061         sig0i=sig0(it)
6062         sig0inv=1.0D0/sig0i**2
6063         delthec=thetai-thet_pred_mean
6064         delthe0=thetai-theta0i
6065         term1=-0.5D0*sigcsq*delthec*delthec
6066         term2=-0.5D0*sig0inv*delthe0*delthe0
6067 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6068 ! NaNs in taking the logarithm. We extract the largest exponent which is added
6069 ! to the energy (this being the log of the distribution) at the end of energy
6070 ! term evaluation for this virtual-bond angle.
6071         if (term1.gt.term2) then
6072           termm=term1
6073           term2=dexp(term2-termm)
6074           term1=1.0d0
6075         else
6076           termm=term2
6077           term1=dexp(term1-termm)
6078           term2=1.0d0
6079         endif
6080 ! The ratio between the gamma-independent and gamma-dependent lobes of
6081 ! the distribution is a Gaussian function of thet_pred_mean too.
6082         diffak=gthet(2,it)-thet_pred_mean
6083         ratak=diffak/gthet(3,it)**2
6084         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6085 ! Let's differentiate it in thet_pred_mean NOW.
6086         aktc=ak*ratak
6087 ! Now put together the distribution terms to make complete distribution.
6088         termexp=term1+ak*term2
6089         termpre=sigc+ak*sig0i
6090 ! Contribution of the bending energy from this theta is just the -log of
6091 ! the sum of the contributions from the two lobes and the pre-exponential
6092 ! factor. Simple enough, isn't it?
6093         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6094 ! NOW the derivatives!!!
6095 ! 6/6/97 Take into account the deformation.
6096         E_theta=(delthec*sigcsq*term1 &
6097              +ak*delthe0*sig0inv*term2)/termexp
6098         E_tc=((sigtc+aktc*sig0i)/termpre &
6099             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
6100              aktc*term2)/termexp)
6101       return
6102       end subroutine theteng
6103 #else
6104 !-----------------------------------------------------------------------------
6105       subroutine ebend(etheta)
6106 !
6107 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6108 ! angles gamma and its derivatives in consecutive thetas and gammas.
6109 ! ab initio-derived potentials from
6110 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6111 !
6112 !      implicit real*8 (a-h,o-z)
6113 !      include 'DIMENSIONS'
6114 !      include 'COMMON.LOCAL'
6115 !      include 'COMMON.GEO'
6116 !      include 'COMMON.INTERACT'
6117 !      include 'COMMON.DERIV'
6118 !      include 'COMMON.VAR'
6119 !      include 'COMMON.CHAIN'
6120 !      include 'COMMON.IOUNITS'
6121 !      include 'COMMON.NAMES'
6122 !      include 'COMMON.FFIELD'
6123 !      include 'COMMON.CONTROL'
6124       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
6125       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
6126       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
6127       logical :: lprn=.false., lprn1=.false.
6128 !el local variables
6129       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
6130       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
6131       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
6132 ! local variables for constrains
6133       real(kind=8) :: difi,thetiii
6134        integer itheta
6135 !      write(iout,*) "in ebend",ithet_start,ithet_end
6136       call flush(iout)
6137       etheta=0.0D0
6138       do i=ithet_start,ithet_end
6139         if (itype(i-1,1).eq.ntyp1) cycle
6140         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
6141         if (iabs(itype(i+1,1)).eq.20) iblock=2
6142         if (iabs(itype(i+1,1)).ne.20) iblock=1
6143         dethetai=0.0d0
6144         dephii=0.0d0
6145         dephii1=0.0d0
6146         theti2=0.5d0*theta(i)
6147         ityp2=ithetyp((itype(i-1,1)))
6148         do k=1,nntheterm
6149           coskt(k)=dcos(k*theti2)
6150           sinkt(k)=dsin(k*theti2)
6151         enddo
6152         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
6153 #ifdef OSF
6154           phii=phi(i)
6155           if (phii.ne.phii) phii=150.0
6156 #else
6157           phii=phi(i)
6158 #endif
6159           ityp1=ithetyp((itype(i-2,1)))
6160 ! propagation of chirality for glycine type
6161           do k=1,nsingle
6162             cosph1(k)=dcos(k*phii)
6163             sinph1(k)=dsin(k*phii)
6164           enddo
6165         else
6166           phii=0.0d0
6167           ityp1=ithetyp(itype(i-2,1))
6168           do k=1,nsingle
6169             cosph1(k)=0.0d0
6170             sinph1(k)=0.0d0
6171           enddo
6172         endif
6173         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
6174 #ifdef OSF
6175           phii1=phi(i+1)
6176           if (phii1.ne.phii1) phii1=150.0
6177           phii1=pinorm(phii1)
6178 #else
6179           phii1=phi(i+1)
6180 #endif
6181           ityp3=ithetyp((itype(i,1)))
6182           do k=1,nsingle
6183             cosph2(k)=dcos(k*phii1)
6184             sinph2(k)=dsin(k*phii1)
6185           enddo
6186         else
6187           phii1=0.0d0
6188           ityp3=ithetyp(itype(i,1))
6189           do k=1,nsingle
6190             cosph2(k)=0.0d0
6191             sinph2(k)=0.0d0
6192           enddo
6193         endif
6194         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6195         do k=1,ndouble
6196           do l=1,k-1
6197             ccl=cosph1(l)*cosph2(k-l)
6198             ssl=sinph1(l)*sinph2(k-l)
6199             scl=sinph1(l)*cosph2(k-l)
6200             csl=cosph1(l)*sinph2(k-l)
6201             cosph1ph2(l,k)=ccl-ssl
6202             cosph1ph2(k,l)=ccl+ssl
6203             sinph1ph2(l,k)=scl+csl
6204             sinph1ph2(k,l)=scl-csl
6205           enddo
6206         enddo
6207         if (lprn) then
6208         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
6209           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6210         write (iout,*) "coskt and sinkt"
6211         do k=1,nntheterm
6212           write (iout,*) k,coskt(k),sinkt(k)
6213         enddo
6214         endif
6215         do k=1,ntheterm
6216           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6217           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
6218             *coskt(k)
6219           if (lprn) &
6220           write (iout,*) "k",k,&
6221            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
6222            " ethetai",ethetai
6223         enddo
6224         if (lprn) then
6225         write (iout,*) "cosph and sinph"
6226         do k=1,nsingle
6227           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6228         enddo
6229         write (iout,*) "cosph1ph2 and sinph2ph2"
6230         do k=2,ndouble
6231           do l=1,k-1
6232             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
6233                sinph1ph2(l,k),sinph1ph2(k,l)
6234           enddo
6235         enddo
6236         write(iout,*) "ethetai",ethetai
6237         endif
6238         do m=1,ntheterm2
6239           do k=1,nsingle
6240             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
6241                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
6242                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
6243                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6244             ethetai=ethetai+sinkt(m)*aux
6245             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6246             dephii=dephii+k*sinkt(m)* &
6247                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
6248                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6249             dephii1=dephii1+k*sinkt(m)* &
6250                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
6251                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6252             if (lprn) &
6253             write (iout,*) "m",m," k",k," bbthet", &
6254                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
6255                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
6256                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
6257                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6258           enddo
6259         enddo
6260         if (lprn) &
6261         write(iout,*) "ethetai",ethetai
6262         do m=1,ntheterm3
6263           do k=2,ndouble
6264             do l=1,k-1
6265               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6266                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
6267                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6268                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6269               ethetai=ethetai+sinkt(m)*aux
6270               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6271               dephii=dephii+l*sinkt(m)* &
6272                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
6273                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6274                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6275                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6276               dephii1=dephii1+(k-l)*sinkt(m)* &
6277                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6278                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6279                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
6280                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6281               if (lprn) then
6282               write (iout,*) "m",m," k",k," l",l," ffthet",&
6283                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6284                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
6285                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6286                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
6287                   " ethetai",ethetai
6288               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
6289                   cosph1ph2(k,l)*sinkt(m),&
6290                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6291               endif
6292             enddo
6293           enddo
6294         enddo
6295 10      continue
6296 !        lprn1=.true.
6297         if (lprn1) &
6298           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
6299          i,theta(i)*rad2deg,phii*rad2deg,&
6300          phii1*rad2deg,ethetai
6301 !        lprn1=.false.
6302         etheta=etheta+ethetai
6303         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6304                                     'ebend',i,ethetai
6305         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6306         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6307         gloc(nphi+i-2,icg)=wang*dethetai
6308       enddo
6309 !-----------thete constrains
6310 !      if (tor_mode.ne.2) then
6311
6312       return
6313       end subroutine ebend
6314 #endif
6315 #ifdef CRYST_SC
6316 !-----------------------------------------------------------------------------
6317       subroutine esc(escloc)
6318 ! Calculate the local energy of a side chain and its derivatives in the
6319 ! corresponding virtual-bond valence angles THETA and the spherical angles
6320 ! ALPHA and OMEGA.
6321 !
6322       use comm_sccalc
6323 !      implicit real*8 (a-h,o-z)
6324 !      include 'DIMENSIONS'
6325 !      include 'COMMON.GEO'
6326 !      include 'COMMON.LOCAL'
6327 !      include 'COMMON.VAR'
6328 !      include 'COMMON.INTERACT'
6329 !      include 'COMMON.DERIV'
6330 !      include 'COMMON.CHAIN'
6331 !      include 'COMMON.IOUNITS'
6332 !      include 'COMMON.NAMES'
6333 !      include 'COMMON.FFIELD'
6334 !      include 'COMMON.CONTROL'
6335       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
6336          ddersc0,ddummy,xtemp,temp
6337 !el      real(kind=8) :: time11,time12,time112,theti
6338       real(kind=8) :: escloc,delta
6339 !el      integer :: it,nlobit
6340 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6341 !el local variables
6342       integer :: i,k
6343       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
6344        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6345       delta=0.02d0*pi
6346       escloc=0.0D0
6347 !     write (iout,'(a)') 'ESC'
6348       do i=loc_start,loc_end
6349         it=itype(i,1)
6350         if (it.eq.ntyp1) cycle
6351         if (it.eq.10) goto 1
6352         nlobit=nlob(iabs(it))
6353 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
6354 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6355         theti=theta(i+1)-pipol
6356         x(1)=dtan(theti)
6357         x(2)=alph(i)
6358         x(3)=omeg(i)
6359
6360         if (x(2).gt.pi-delta) then
6361           xtemp(1)=x(1)
6362           xtemp(2)=pi-delta
6363           xtemp(3)=x(3)
6364           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6365           xtemp(2)=pi
6366           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6367           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
6368               escloci,dersc(2))
6369           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6370               ddersc0(1),dersc(1))
6371           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
6372               ddersc0(3),dersc(3))
6373           xtemp(2)=pi-delta
6374           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6375           xtemp(2)=pi
6376           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6377           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
6378                   dersc0(2),esclocbi,dersc02)
6379           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6380                   dersc12,dersc01)
6381           call splinthet(x(2),0.5d0*delta,ss,ssd)
6382           dersc0(1)=dersc01
6383           dersc0(2)=dersc02
6384           dersc0(3)=0.0d0
6385           do k=1,3
6386             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6387           enddo
6388           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6389 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6390 !    &             esclocbi,ss,ssd
6391           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6392 !         escloci=esclocbi
6393 !         write (iout,*) escloci
6394         else if (x(2).lt.delta) then
6395           xtemp(1)=x(1)
6396           xtemp(2)=delta
6397           xtemp(3)=x(3)
6398           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6399           xtemp(2)=0.0d0
6400           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6401           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
6402               escloci,dersc(2))
6403           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6404               ddersc0(1),dersc(1))
6405           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6406               ddersc0(3),dersc(3))
6407           xtemp(2)=delta
6408           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6409           xtemp(2)=0.0d0
6410           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6411           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6412                   dersc0(2),esclocbi,dersc02)
6413           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6414                   dersc12,dersc01)
6415           dersc0(1)=dersc01
6416           dersc0(2)=dersc02
6417           dersc0(3)=0.0d0
6418           call splinthet(x(2),0.5d0*delta,ss,ssd)
6419           do k=1,3
6420             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6421           enddo
6422           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6423 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6424 !    &             esclocbi,ss,ssd
6425           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6426 !         write (iout,*) escloci
6427         else
6428           call enesc(x,escloci,dersc,ddummy,.false.)
6429         endif
6430
6431         escloc=escloc+escloci
6432         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6433            'escloc',i,escloci
6434 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6435
6436         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6437          wscloc*dersc(1)
6438         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6439         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6440     1   continue
6441       enddo
6442       return
6443       end subroutine esc
6444 !-----------------------------------------------------------------------------
6445       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6446
6447       use comm_sccalc
6448 !      implicit real*8 (a-h,o-z)
6449 !      include 'DIMENSIONS'
6450 !      include 'COMMON.GEO'
6451 !      include 'COMMON.LOCAL'
6452 !      include 'COMMON.IOUNITS'
6453 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6454       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6455       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6456       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6457       real(kind=8) :: escloci
6458       logical :: mixed
6459 !el local variables
6460       integer :: j,iii,l,k !el,it,nlobit
6461       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6462 !el       time11,time12,time112
6463 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6464         escloc_i=0.0D0
6465         do j=1,3
6466           dersc(j)=0.0D0
6467           if (mixed) ddersc(j)=0.0d0
6468         enddo
6469         x3=x(3)
6470
6471 ! Because of periodicity of the dependence of the SC energy in omega we have
6472 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6473 ! To avoid underflows, first compute & store the exponents.
6474
6475         do iii=-1,1
6476
6477           x(3)=x3+iii*dwapi
6478
6479           do j=1,nlobit
6480             do k=1,3
6481               z(k)=x(k)-censc(k,j,it)
6482             enddo
6483             do k=1,3
6484               Axk=0.0D0
6485               do l=1,3
6486                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6487               enddo
6488               Ax(k,j,iii)=Axk
6489             enddo
6490             expfac=0.0D0
6491             do k=1,3
6492               expfac=expfac+Ax(k,j,iii)*z(k)
6493             enddo
6494             contr(j,iii)=expfac
6495           enddo ! j
6496
6497         enddo ! iii
6498
6499         x(3)=x3
6500 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6501 ! subsequent NaNs and INFs in energy calculation.
6502 ! Find the largest exponent
6503         emin=contr(1,-1)
6504         do iii=-1,1
6505           do j=1,nlobit
6506             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6507           enddo
6508         enddo
6509         emin=0.5D0*emin
6510 !d      print *,'it=',it,' emin=',emin
6511
6512 ! Compute the contribution to SC energy and derivatives
6513         do iii=-1,1
6514
6515           do j=1,nlobit
6516 #ifdef OSF
6517             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6518             if(adexp.ne.adexp) adexp=1.0
6519             expfac=dexp(adexp)
6520 #else
6521             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6522 #endif
6523 !d          print *,'j=',j,' expfac=',expfac
6524             escloc_i=escloc_i+expfac
6525             do k=1,3
6526               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6527             enddo
6528             if (mixed) then
6529               do k=1,3,2
6530                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6531                   +gaussc(k,2,j,it))*expfac
6532               enddo
6533             endif
6534           enddo
6535
6536         enddo ! iii
6537
6538         dersc(1)=dersc(1)/cos(theti)**2
6539         ddersc(1)=ddersc(1)/cos(theti)**2
6540         ddersc(3)=ddersc(3)
6541
6542         escloci=-(dlog(escloc_i)-emin)
6543         do j=1,3
6544           dersc(j)=dersc(j)/escloc_i
6545         enddo
6546         if (mixed) then
6547           do j=1,3,2
6548             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6549           enddo
6550         endif
6551       return
6552       end subroutine enesc
6553 !-----------------------------------------------------------------------------
6554       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6555
6556       use comm_sccalc
6557 !      implicit real*8 (a-h,o-z)
6558 !      include 'DIMENSIONS'
6559 !      include 'COMMON.GEO'
6560 !      include 'COMMON.LOCAL'
6561 !      include 'COMMON.IOUNITS'
6562 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6563       real(kind=8),dimension(3) :: x,z,dersc
6564       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6565       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6566       real(kind=8) :: escloci,dersc12,emin
6567       logical :: mixed
6568 !el local varables
6569       integer :: j,k,l !el,it,nlobit
6570       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6571
6572       escloc_i=0.0D0
6573
6574       do j=1,3
6575         dersc(j)=0.0D0
6576       enddo
6577
6578       do j=1,nlobit
6579         do k=1,2
6580           z(k)=x(k)-censc(k,j,it)
6581         enddo
6582         z(3)=dwapi
6583         do k=1,3
6584           Axk=0.0D0
6585           do l=1,3
6586             Axk=Axk+gaussc(l,k,j,it)*z(l)
6587           enddo
6588           Ax(k,j)=Axk
6589         enddo
6590         expfac=0.0D0
6591         do k=1,3
6592           expfac=expfac+Ax(k,j)*z(k)
6593         enddo
6594         contr(j)=expfac
6595       enddo ! j
6596
6597 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6598 ! subsequent NaNs and INFs in energy calculation.
6599 ! Find the largest exponent
6600       emin=contr(1)
6601       do j=1,nlobit
6602         if (emin.gt.contr(j)) emin=contr(j)
6603       enddo
6604       emin=0.5D0*emin
6605
6606 ! Compute the contribution to SC energy and derivatives
6607
6608       dersc12=0.0d0
6609       do j=1,nlobit
6610         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6611         escloc_i=escloc_i+expfac
6612         do k=1,2
6613           dersc(k)=dersc(k)+Ax(k,j)*expfac
6614         enddo
6615         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6616                   +gaussc(1,2,j,it))*expfac
6617         dersc(3)=0.0d0
6618       enddo
6619
6620       dersc(1)=dersc(1)/cos(theti)**2
6621       dersc12=dersc12/cos(theti)**2
6622       escloci=-(dlog(escloc_i)-emin)
6623       do j=1,2
6624         dersc(j)=dersc(j)/escloc_i
6625       enddo
6626       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6627       return
6628       end subroutine enesc_bound
6629 #else
6630 !-----------------------------------------------------------------------------
6631       subroutine esc(escloc)
6632 ! Calculate the local energy of a side chain and its derivatives in the
6633 ! corresponding virtual-bond valence angles THETA and the spherical angles
6634 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6635 ! added by Urszula Kozlowska. 07/11/2007
6636 !
6637       use comm_sccalc
6638 !      implicit real*8 (a-h,o-z)
6639 !      include 'DIMENSIONS'
6640 !      include 'COMMON.GEO'
6641 !      include 'COMMON.LOCAL'
6642 !      include 'COMMON.VAR'
6643 !      include 'COMMON.SCROT'
6644 !      include 'COMMON.INTERACT'
6645 !      include 'COMMON.DERIV'
6646 !      include 'COMMON.CHAIN'
6647 !      include 'COMMON.IOUNITS'
6648 !      include 'COMMON.NAMES'
6649 !      include 'COMMON.FFIELD'
6650 !      include 'COMMON.CONTROL'
6651 !      include 'COMMON.VECTORS'
6652       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6653       real(kind=8),dimension(65) :: x
6654       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6655          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6656       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6657       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6658          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6659 !el local variables
6660       integer :: i,j,k !el,it,nlobit
6661       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6662 !el      real(kind=8) :: time11,time12,time112,theti
6663 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6664       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6665                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6666                    sumene1x,sumene2x,sumene3x,sumene4x,&
6667                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6668                    cosfac2xx,sinfac2yy
6669 #ifdef DEBUG
6670       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6671                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6672                    de_dt_num
6673 #endif
6674 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6675
6676       delta=0.02d0*pi
6677       escloc=0.0D0
6678       do i=loc_start,loc_end
6679         if (itype(i,1).eq.ntyp1) cycle
6680         costtab(i+1) =dcos(theta(i+1))
6681         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6682         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6683         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6684         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6685         cosfac=dsqrt(cosfac2)
6686         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6687         sinfac=dsqrt(sinfac2)
6688         it=iabs(itype(i,1))
6689         if (it.eq.10) goto 1
6690 !
6691 !  Compute the axes of tghe local cartesian coordinates system; store in
6692 !   x_prime, y_prime and z_prime
6693 !
6694         do j=1,3
6695           x_prime(j) = 0.00
6696           y_prime(j) = 0.00
6697           z_prime(j) = 0.00
6698         enddo
6699 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6700 !     &   dc_norm(3,i+nres)
6701         do j = 1,3
6702           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6703           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6704         enddo
6705         do j = 1,3
6706           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6707         enddo
6708 !       write (2,*) "i",i
6709 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6710 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6711 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6712 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6713 !      & " xy",scalar(x_prime(1),y_prime(1)),
6714 !      & " xz",scalar(x_prime(1),z_prime(1)),
6715 !      & " yy",scalar(y_prime(1),y_prime(1)),
6716 !      & " yz",scalar(y_prime(1),z_prime(1)),
6717 !      & " zz",scalar(z_prime(1),z_prime(1))
6718 !
6719 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6720 ! to local coordinate system. Store in xx, yy, zz.
6721 !
6722         xx=0.0d0
6723         yy=0.0d0
6724         zz=0.0d0
6725         do j = 1,3
6726           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6727           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6728           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6729         enddo
6730
6731         xxtab(i)=xx
6732         yytab(i)=yy
6733         zztab(i)=zz
6734 !
6735 ! Compute the energy of the ith side cbain
6736 !
6737 !        write (2,*) "xx",xx," yy",yy," zz",zz
6738         it=iabs(itype(i,1))
6739         do j = 1,65
6740           x(j) = sc_parmin(j,it)
6741         enddo
6742 #ifdef CHECK_COORD
6743 !c diagnostics - remove later
6744         xx1 = dcos(alph(2))
6745         yy1 = dsin(alph(2))*dcos(omeg(2))
6746         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6747         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6748           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6749           xx1,yy1,zz1
6750 !,"  --- ", xx_w,yy_w,zz_w
6751 ! end diagnostics
6752 #endif
6753         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6754          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6755          + x(10)*yy*zz
6756         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6757          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6758          + x(20)*yy*zz
6759         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6760          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6761          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6762          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6763          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6764          +x(40)*xx*yy*zz
6765         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6766          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6767          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6768          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6769          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6770          +x(60)*xx*yy*zz
6771         dsc_i   = 0.743d0+x(61)
6772         dp2_i   = 1.9d0+x(62)
6773         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6774                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6775         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6776                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6777         s1=(1+x(63))/(0.1d0 + dscp1)
6778         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6779         s2=(1+x(65))/(0.1d0 + dscp2)
6780         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6781         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6782       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6783 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6784 !     &   sumene4,
6785 !     &   dscp1,dscp2,sumene
6786 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6787         escloc = escloc + sumene
6788        if (energy_dec) write (2,*) "i",i," itype",itype(i,1)," it",it, &
6789         " escloc",sumene,escloc,it,itype(i,1)
6790 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6791 !     & ,zz,xx,yy
6792 !#define DEBUG
6793 #ifdef DEBUG
6794 !
6795 ! This section to check the numerical derivatives of the energy of ith side
6796 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6797 ! #define DEBUG in the code to turn it on.
6798 !
6799         write (2,*) "sumene               =",sumene
6800         aincr=1.0d-7
6801         xxsave=xx
6802         xx=xx+aincr
6803         write (2,*) xx,yy,zz
6804         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6805         de_dxx_num=(sumenep-sumene)/aincr
6806         xx=xxsave
6807         write (2,*) "xx+ sumene from enesc=",sumenep
6808         yysave=yy
6809         yy=yy+aincr
6810         write (2,*) xx,yy,zz
6811         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6812         de_dyy_num=(sumenep-sumene)/aincr
6813         yy=yysave
6814         write (2,*) "yy+ sumene from enesc=",sumenep
6815         zzsave=zz
6816         zz=zz+aincr
6817         write (2,*) xx,yy,zz
6818         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6819         de_dzz_num=(sumenep-sumene)/aincr
6820         zz=zzsave
6821         write (2,*) "zz+ sumene from enesc=",sumenep
6822         costsave=cost2tab(i+1)
6823         sintsave=sint2tab(i+1)
6824         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6825         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6826         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6827         de_dt_num=(sumenep-sumene)/aincr
6828         write (2,*) " t+ sumene from enesc=",sumenep
6829         cost2tab(i+1)=costsave
6830         sint2tab(i+1)=sintsave
6831 ! End of diagnostics section.
6832 #endif
6833 !
6834 ! Compute the gradient of esc
6835 !
6836 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6837         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6838         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6839         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6840         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6841         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6842         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6843         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6844         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6845         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6846            *(pom_s1/dscp1+pom_s16*dscp1**4)
6847         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6848            *(pom_s2/dscp2+pom_s26*dscp2**4)
6849         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6850         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6851         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6852         +x(40)*yy*zz
6853         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6854         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6855         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6856         +x(60)*yy*zz
6857         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6858               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6859               +(pom1+pom2)*pom_dx
6860 #ifdef DEBUG
6861         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6862 #endif
6863 !
6864         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6865         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6866         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6867         +x(40)*xx*zz
6868         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6869         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6870         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6871         +x(59)*zz**2 +x(60)*xx*zz
6872         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6873               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6874               +(pom1-pom2)*pom_dy
6875 #ifdef DEBUG
6876         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6877 #endif
6878 !
6879         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6880         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6881         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6882         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6883         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6884         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6885         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6886         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6887 #ifdef DEBUG
6888         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
6889 #endif
6890 !
6891         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6892         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6893         +pom1*pom_dt1+pom2*pom_dt2
6894 #ifdef DEBUG
6895         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
6896 #endif
6897 !
6898 !
6899        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6900        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6901        cosfac2xx=cosfac2*xx
6902        sinfac2yy=sinfac2*yy
6903        do k = 1,3
6904          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6905             vbld_inv(i+1)
6906          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6907             vbld_inv(i)
6908          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6909          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6910 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6911 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6912 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6913 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6914          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6915          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6916          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6917          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6918          dZZ_Ci1(k)=0.0d0
6919          dZZ_Ci(k)=0.0d0
6920          do j=1,3
6921            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6922            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6923            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6924            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6925          enddo
6926
6927          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6928          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6929          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6930          (z_prime(k)-zz*dC_norm(k,i+nres))
6931 !
6932          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6933          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6934        enddo
6935
6936        do k=1,3
6937          dXX_Ctab(k,i)=dXX_Ci(k)
6938          dXX_C1tab(k,i)=dXX_Ci1(k)
6939          dYY_Ctab(k,i)=dYY_Ci(k)
6940          dYY_C1tab(k,i)=dYY_Ci1(k)
6941          dZZ_Ctab(k,i)=dZZ_Ci(k)
6942          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6943          dXX_XYZtab(k,i)=dXX_XYZ(k)
6944          dYY_XYZtab(k,i)=dYY_XYZ(k)
6945          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6946        enddo
6947
6948        do k = 1,3
6949 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6950 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6951 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6952 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6953 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6954 !     &    dt_dci(k)
6955 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6956 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6957          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6958           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6959          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6960           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6961          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6962           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6963        enddo
6964 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6965 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6966
6967 ! to check gradient call subroutine check_grad
6968
6969     1 continue
6970       enddo
6971       return
6972       end subroutine esc
6973 !-----------------------------------------------------------------------------
6974       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6975 !      implicit none
6976       real(kind=8),dimension(65) :: x
6977       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6978         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6979
6980       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6981         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6982         + x(10)*yy*zz
6983       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6984         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6985         + x(20)*yy*zz
6986       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6987         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6988         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6989         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6990         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6991         +x(40)*xx*yy*zz
6992       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6993         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6994         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6995         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6996         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6997         +x(60)*xx*yy*zz
6998       dsc_i   = 0.743d0+x(61)
6999       dp2_i   = 1.9d0+x(62)
7000       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7001                 *(xx*cost2+yy*sint2))
7002       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7003                 *(xx*cost2-yy*sint2))
7004       s1=(1+x(63))/(0.1d0 + dscp1)
7005       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7006       s2=(1+x(65))/(0.1d0 + dscp2)
7007       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7008       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
7009        + (sumene4*cost2 +sumene2)*(s2+s2_6)
7010       enesc=sumene
7011       return
7012       end function enesc
7013 #endif
7014 !-----------------------------------------------------------------------------
7015       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7016 !
7017 ! This procedure calculates two-body contact function g(rij) and its derivative:
7018 !
7019 !           eps0ij                                     !       x < -1
7020 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7021 !            0                                         !       x > 1
7022 !
7023 ! where x=(rij-r0ij)/delta
7024 !
7025 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7026 !
7027 !      implicit none
7028       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
7029       real(kind=8) :: x,x2,x4,delta
7030 !     delta=0.02D0*r0ij
7031 !      delta=0.2D0*r0ij
7032       x=(rij-r0ij)/delta
7033       if (x.lt.-1.0D0) then
7034         fcont=eps0ij
7035         fprimcont=0.0D0
7036       else if (x.le.1.0D0) then
7037         x2=x*x
7038         x4=x2*x2
7039         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7040         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7041       else
7042         fcont=0.0D0
7043         fprimcont=0.0D0
7044       endif
7045       return
7046       end subroutine gcont
7047 !-----------------------------------------------------------------------------
7048       subroutine splinthet(theti,delta,ss,ssder)
7049 !      implicit real*8 (a-h,o-z)
7050 !      include 'DIMENSIONS'
7051 !      include 'COMMON.VAR'
7052 !      include 'COMMON.GEO'
7053       real(kind=8) :: theti,delta,ss,ssder
7054       real(kind=8) :: thetup,thetlow
7055       thetup=pi-delta
7056       thetlow=delta
7057       if (theti.gt.pipol) then
7058         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7059       else
7060         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7061         ssder=-ssder
7062       endif
7063       return
7064       end subroutine splinthet
7065 !-----------------------------------------------------------------------------
7066       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7067 !      implicit none
7068       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
7069       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7070       a1=fprim0*delta/(f1-f0)
7071       a2=3.0d0-2.0d0*a1
7072       a3=a1-2.0d0
7073       ksi=(x-x0)/delta
7074       ksi2=ksi*ksi
7075       ksi3=ksi2*ksi
7076       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7077       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7078       return
7079       end subroutine spline1
7080 !-----------------------------------------------------------------------------
7081       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7082 !      implicit none
7083       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
7084       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7085       ksi=(x-x0)/delta
7086       ksi2=ksi*ksi
7087       ksi3=ksi2*ksi
7088       a1=fprim0x*delta
7089       a2=3*(f1x-f0x)-2*fprim0x*delta
7090       a3=fprim0x*delta-2*(f1x-f0x)
7091       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7092       return
7093       end subroutine spline2
7094 !-----------------------------------------------------------------------------
7095 #ifdef CRYST_TOR
7096 !-----------------------------------------------------------------------------
7097       subroutine etor(etors,edihcnstr)
7098 !      implicit real*8 (a-h,o-z)
7099 !      include 'DIMENSIONS'
7100 !      include 'COMMON.VAR'
7101 !      include 'COMMON.GEO'
7102 !      include 'COMMON.LOCAL'
7103 !      include 'COMMON.TORSION'
7104 !      include 'COMMON.INTERACT'
7105 !      include 'COMMON.DERIV'
7106 !      include 'COMMON.CHAIN'
7107 !      include 'COMMON.NAMES'
7108 !      include 'COMMON.IOUNITS'
7109 !      include 'COMMON.FFIELD'
7110 !      include 'COMMON.TORCNSTR'
7111 !      include 'COMMON.CONTROL'
7112       real(kind=8) :: etors,edihcnstr
7113       logical :: lprn
7114 !el local variables
7115       integer :: i,j,
7116       real(kind=8) :: phii,fac,etors_ii
7117
7118 ! Set lprn=.true. for debugging
7119       lprn=.false.
7120 !      lprn=.true.
7121       etors=0.0D0
7122       do i=iphi_start,iphi_end
7123       etors_ii=0.0D0
7124         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7125             .or. itype(i,1).eq.ntyp1) cycle
7126         itori=itortyp(itype(i-2,1))
7127         itori1=itortyp(itype(i-1,1))
7128         phii=phi(i)
7129         gloci=0.0D0
7130 ! Proline-Proline pair is a special case...
7131         if (itori.eq.3 .and. itori1.eq.3) then
7132           if (phii.gt.-dwapi3) then
7133             cosphi=dcos(3*phii)
7134             fac=1.0D0/(1.0D0-cosphi)
7135             etorsi=v1(1,3,3)*fac
7136             etorsi=etorsi+etorsi
7137             etors=etors+etorsi-v1(1,3,3)
7138             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7139             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7140           endif
7141           do j=1,3
7142             v1ij=v1(j+1,itori,itori1)
7143             v2ij=v2(j+1,itori,itori1)
7144             cosphi=dcos(j*phii)
7145             sinphi=dsin(j*phii)
7146             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7147             if (energy_dec) etors_ii=etors_ii+ &
7148                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7149             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7150           enddo
7151         else
7152           do j=1,nterm_old
7153             v1ij=v1(j,itori,itori1)
7154             v2ij=v2(j,itori,itori1)
7155             cosphi=dcos(j*phii)
7156             sinphi=dsin(j*phii)
7157             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7158             if (energy_dec) etors_ii=etors_ii+ &
7159                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7160             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7161           enddo
7162         endif
7163         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7164              'etor',i,etors_ii
7165         if (lprn) &
7166         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7167         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7168         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7169         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7170 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7171       enddo
7172 ! 6/20/98 - dihedral angle constraints
7173       edihcnstr=0.0d0
7174       do i=1,ndih_constr
7175         itori=idih_constr(i)
7176         phii=phi(itori)
7177         difi=phii-phi0(i)
7178         if (difi.gt.drange(i)) then
7179           difi=difi-drange(i)
7180           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7181           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7182         else if (difi.lt.-drange(i)) then
7183           difi=difi+drange(i)
7184           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7185           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7186         endif
7187 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7188 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7189       enddo
7190 !      write (iout,*) 'edihcnstr',edihcnstr
7191       return
7192       end subroutine etor
7193 !-----------------------------------------------------------------------------
7194       subroutine etor_d(etors_d)
7195       real(kind=8) :: etors_d
7196       etors_d=0.0d0
7197       return
7198       end subroutine etor_d
7199 #else
7200 !-----------------------------------------------------------------------------
7201       subroutine etor(etors)
7202 !      implicit real*8 (a-h,o-z)
7203 !      include 'DIMENSIONS'
7204 !      include 'COMMON.VAR'
7205 !      include 'COMMON.GEO'
7206 !      include 'COMMON.LOCAL'
7207 !      include 'COMMON.TORSION'
7208 !      include 'COMMON.INTERACT'
7209 !      include 'COMMON.DERIV'
7210 !      include 'COMMON.CHAIN'
7211 !      include 'COMMON.NAMES'
7212 !      include 'COMMON.IOUNITS'
7213 !      include 'COMMON.FFIELD'
7214 !      include 'COMMON.TORCNSTR'
7215 !      include 'COMMON.CONTROL'
7216       real(kind=8) :: etors,edihcnstr
7217       logical :: lprn
7218 !el local variables
7219       integer :: i,j,iblock,itori,itori1
7220       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7221                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
7222 ! Set lprn=.true. for debugging
7223       lprn=.false.
7224 !     lprn=.true.
7225       etors=0.0D0
7226       do i=iphi_start,iphi_end
7227         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7228              .or. itype(i-3,1).eq.ntyp1 &
7229              .or. itype(i,1).eq.ntyp1) cycle
7230         etors_ii=0.0D0
7231          if (iabs(itype(i,1)).eq.20) then
7232          iblock=2
7233          else
7234          iblock=1
7235          endif
7236         itori=itortyp(itype(i-2,1))
7237         itori1=itortyp(itype(i-1,1))
7238         phii=phi(i)
7239         gloci=0.0D0
7240 ! Regular cosine and sine terms
7241         do j=1,nterm(itori,itori1,iblock)
7242           v1ij=v1(j,itori,itori1,iblock)
7243           v2ij=v2(j,itori,itori1,iblock)
7244           cosphi=dcos(j*phii)
7245           sinphi=dsin(j*phii)
7246           etors=etors+v1ij*cosphi+v2ij*sinphi
7247           if (energy_dec) etors_ii=etors_ii+ &
7248                      v1ij*cosphi+v2ij*sinphi
7249           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7250         enddo
7251 ! Lorentz terms
7252 !                         v1
7253 !  E = SUM ----------------------------------- - v1
7254 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7255 !
7256         cosphi=dcos(0.5d0*phii)
7257         sinphi=dsin(0.5d0*phii)
7258         do j=1,nlor(itori,itori1,iblock)
7259           vl1ij=vlor1(j,itori,itori1)
7260           vl2ij=vlor2(j,itori,itori1)
7261           vl3ij=vlor3(j,itori,itori1)
7262           pom=vl2ij*cosphi+vl3ij*sinphi
7263           pom1=1.0d0/(pom*pom+1.0d0)
7264           etors=etors+vl1ij*pom1
7265           if (energy_dec) etors_ii=etors_ii+ &
7266                      vl1ij*pom1
7267           pom=-pom*pom1*pom1
7268           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7269         enddo
7270 ! Subtract the constant term
7271         etors=etors-v0(itori,itori1,iblock)
7272           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7273                'etor',i,etors_ii-v0(itori,itori1,iblock)
7274         if (lprn) &
7275         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7276         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7277         (v1(j,itori,itori1,iblock),j=1,6),&
7278         (v2(j,itori,itori1,iblock),j=1,6)
7279         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7280 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7281       enddo
7282 ! 6/20/98 - dihedral angle constraints
7283       return
7284       end subroutine etor
7285 !C The rigorous attempt to derive energy function
7286 !-------------------------------------------------------------------------------------------
7287       subroutine etor_kcc(etors)
7288       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7289       real(kind=8) :: etors,glocig,glocit1,glocit2,sinthet1,&
7290        sinthet2,costhet1,costhet2,sint1t2,sint1t2n,phii,sinphi,cosphi,&
7291        sint1t2n1,sumvalc,gradvalct1,gradvalct2,sumvals,gradvalst1,&
7292        gradvalst2,etori
7293       logical lprn
7294       integer :: i,j,itori,itori1,nval,k,l
7295
7296       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7297       etors=0.0D0
7298       do i=iphi_start,iphi_end
7299 !C ANY TWO ARE DUMMY ATOMS in row CYCLE
7300 !c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7301 !c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7302 !c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7303         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7304            .or. itype(i,1).eq.ntyp1 .or. itype(i-3,1).eq.ntyp1) cycle
7305         itori=itortyp(itype(i-2,1))
7306         itori1=itortyp(itype(i-1,1))
7307         phii=phi(i)
7308         glocig=0.0D0
7309         glocit1=0.0d0
7310         glocit2=0.0d0
7311 !C to avoid multiple devision by 2
7312 !c        theti22=0.5d0*theta(i)
7313 !C theta 12 is the theta_1 /2
7314 !C theta 22 is theta_2 /2
7315 !c        theti12=0.5d0*theta(i-1)
7316 !C and appropriate sinus function
7317         sinthet1=dsin(theta(i-1))
7318         sinthet2=dsin(theta(i))
7319         costhet1=dcos(theta(i-1))
7320         costhet2=dcos(theta(i))
7321 !C to speed up lets store its mutliplication
7322         sint1t2=sinthet2*sinthet1
7323         sint1t2n=1.0d0
7324 !C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7325 !C +d_n*sin(n*gamma)) *
7326 !C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7327 !C we have two sum 1) Non-Chebyshev which is with n and gamma
7328         nval=nterm_kcc_Tb(itori,itori1)
7329         c1(0)=0.0d0
7330         c2(0)=0.0d0
7331         c1(1)=1.0d0
7332         c2(1)=1.0d0
7333         do j=2,nval
7334           c1(j)=c1(j-1)*costhet1
7335           c2(j)=c2(j-1)*costhet2
7336         enddo
7337         etori=0.0d0
7338
7339        do j=1,nterm_kcc(itori,itori1)
7340           cosphi=dcos(j*phii)
7341           sinphi=dsin(j*phii)
7342           sint1t2n1=sint1t2n
7343           sint1t2n=sint1t2n*sint1t2
7344           sumvalc=0.0d0
7345           gradvalct1=0.0d0
7346           gradvalct2=0.0d0
7347           do k=1,nval
7348             do l=1,nval
7349               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7350               gradvalct1=gradvalct1+ &
7351                 (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7352               gradvalct2=gradvalct2+ &
7353                 (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7354             enddo
7355           enddo
7356           gradvalct1=-gradvalct1*sinthet1
7357           gradvalct2=-gradvalct2*sinthet2
7358           sumvals=0.0d0
7359           gradvalst1=0.0d0
7360           gradvalst2=0.0d0
7361           do k=1,nval
7362             do l=1,nval
7363               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7364               gradvalst1=gradvalst1+ &
7365                 (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7366               gradvalst2=gradvalst2+ &
7367                 (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7368             enddo
7369           enddo
7370           gradvalst1=-gradvalst1*sinthet1
7371           gradvalst2=-gradvalst2*sinthet2
7372           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7373           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7374 !C glocig is the gradient local i site in gamma
7375           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7376 !C now gradient over theta_1
7377          glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)&
7378         +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7379          glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)&
7380         +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7381         enddo ! j
7382         etors=etors+etori
7383         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7384 !C derivative over theta1
7385         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7386 !C now derivative over theta2
7387         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7388         if (lprn) then
7389          write (iout,*) i-2,i-1,itype(i-2,1),itype(i-1,1),itori,itori1,&
7390             theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7391           write (iout,*) "c1",(c1(k),k=0,nval), &
7392          " c2",(c2(k),k=0,nval)
7393         endif
7394       enddo
7395       return
7396        end  subroutine etor_kcc
7397 !------------------------------------------------------------------------------
7398
7399         subroutine etor_constr(edihcnstr)
7400       real(kind=8) :: etors,edihcnstr
7401       logical :: lprn
7402 !el local variables
7403       integer :: i,j,iblock,itori,itori1
7404       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7405                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom,&
7406                    gaudih_i,gauder_i,s,cos_i,dexpcos_i
7407
7408       if (raw_psipred) then
7409         do i=idihconstr_start,idihconstr_end
7410           itori=idih_constr(i)
7411           phii=phi(itori)
7412           gaudih_i=vpsipred(1,i)
7413           gauder_i=0.0d0
7414           do j=1,2
7415             s = sdihed(j,i)
7416             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7417             dexpcos_i=dexp(-cos_i*cos_i)
7418             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7419           gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i)) &
7420                  *cos_i*dexpcos_i/s**2
7421           enddo
7422           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7423           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7424           if (energy_dec) &
7425           write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)') &
7426           i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),&
7427           phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),&
7428           phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,&
7429           -wdihc*dlog(gaudih_i)
7430         enddo
7431       else
7432
7433       do i=idihconstr_start,idihconstr_end
7434         itori=idih_constr(i)
7435         phii=phi(itori)
7436         difi=pinorm(phii-phi0(i))
7437         if (difi.gt.drange(i)) then
7438           difi=difi-drange(i)
7439           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7440           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7441         else if (difi.lt.-drange(i)) then
7442           difi=difi+drange(i)
7443           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7444           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7445         else
7446           difi=0.0
7447         endif
7448       enddo
7449
7450       endif
7451
7452       return
7453
7454       end subroutine etor_constr
7455 !-----------------------------------------------------------------------------
7456       subroutine etor_d(etors_d)
7457 ! 6/23/01 Compute double torsional energy
7458 !      implicit real*8 (a-h,o-z)
7459 !      include 'DIMENSIONS'
7460 !      include 'COMMON.VAR'
7461 !      include 'COMMON.GEO'
7462 !      include 'COMMON.LOCAL'
7463 !      include 'COMMON.TORSION'
7464 !      include 'COMMON.INTERACT'
7465 !      include 'COMMON.DERIV'
7466 !      include 'COMMON.CHAIN'
7467 !      include 'COMMON.NAMES'
7468 !      include 'COMMON.IOUNITS'
7469 !      include 'COMMON.FFIELD'
7470 !      include 'COMMON.TORCNSTR'
7471       real(kind=8) :: etors_d,etors_d_ii
7472       logical :: lprn
7473 !el local variables
7474       integer :: i,j,k,l,itori,itori1,itori2,iblock
7475       real(kind=8) :: phii,phii1,gloci1,gloci2,&
7476                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
7477                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
7478                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
7479 ! Set lprn=.true. for debugging
7480       lprn=.false.
7481 !     lprn=.true.
7482       etors_d=0.0D0
7483 !      write(iout,*) "a tu??"
7484       do i=iphid_start,iphid_end
7485         etors_d_ii=0.0D0
7486         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7487             .or. itype(i-3,1).eq.ntyp1 &
7488             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
7489         itori=itortyp(itype(i-2,1))
7490         itori1=itortyp(itype(i-1,1))
7491         itori2=itortyp(itype(i,1))
7492         phii=phi(i)
7493         phii1=phi(i+1)
7494         gloci1=0.0D0
7495         gloci2=0.0D0
7496         iblock=1
7497         if (iabs(itype(i+1,1)).eq.20) iblock=2
7498
7499 ! Regular cosine and sine terms
7500         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7501           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7502           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7503           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7504           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7505           cosphi1=dcos(j*phii)
7506           sinphi1=dsin(j*phii)
7507           cosphi2=dcos(j*phii1)
7508           sinphi2=dsin(j*phii1)
7509           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
7510            v2cij*cosphi2+v2sij*sinphi2
7511           if (energy_dec) etors_d_ii=etors_d_ii+ &
7512            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7513           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7514           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7515         enddo
7516         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7517           do l=1,k-1
7518             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7519             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7520             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7521             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7522             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7523             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7524             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7525             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7526             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7527               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7528             if (energy_dec) etors_d_ii=etors_d_ii+ &
7529               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7530               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7531             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
7532               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7533             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
7534               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7535           enddo
7536         enddo
7537         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7538                             'etor_d',i,etors_d_ii
7539         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7540         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7541       enddo
7542       return
7543       end subroutine etor_d
7544 #endif
7545
7546       subroutine ebend_kcc(etheta)
7547       logical lprn
7548       double precision thybt1(maxang_kcc),etheta
7549       integer :: i,iti,j,ihelp
7550       real (kind=8) :: sinthet,costhet,sumth1thyb,gradthybt1
7551 !C Set lprn=.true. for debugging
7552       lprn=energy_dec
7553 !c     lprn=.true.
7554 !C      print *,"wchodze kcc"
7555       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7556       etheta=0.0D0
7557       do i=ithet_start,ithet_end
7558 !c        print *,i,itype(i-1),itype(i),itype(i-2)
7559         if ((itype(i-1,1).eq.ntyp1).or.itype(i-2,1).eq.ntyp1 &
7560        .or.itype(i,1).eq.ntyp1) cycle
7561         iti=iabs(itortyp(itype(i-1,1)))
7562         sinthet=dsin(theta(i))
7563         costhet=dcos(theta(i))
7564         do j=1,nbend_kcc_Tb(iti)
7565           thybt1(j)=v1bend_chyb(j,iti)
7566         enddo
7567         sumth1thyb=v1bend_chyb(0,iti)+ &
7568          tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7569         if (lprn) write (iout,*) i-1,itype(i-1,1),iti,theta(i)*rad2deg,&
7570          sumth1thyb
7571         ihelp=nbend_kcc_Tb(iti)-1
7572         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
7573         etheta=etheta+sumth1thyb
7574 !C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7575         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
7576       enddo
7577       return
7578       end subroutine ebend_kcc
7579 !c------------
7580 !c-------------------------------------------------------------------------------------
7581       subroutine etheta_constr(ethetacnstr)
7582       real (kind=8) :: ethetacnstr,thetiii,difi
7583       integer :: i,itheta
7584       ethetacnstr=0.0d0
7585 !C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7586       do i=ithetaconstr_start,ithetaconstr_end
7587         itheta=itheta_constr(i)
7588         thetiii=theta(itheta)
7589         difi=pinorm(thetiii-theta_constr0(i))
7590         if (difi.gt.theta_drange(i)) then
7591           difi=difi-theta_drange(i)
7592           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7593           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
7594          +for_thet_constr(i)*difi**3
7595         else if (difi.lt.-drange(i)) then
7596           difi=difi+drange(i)
7597           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7598           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
7599           +for_thet_constr(i)*difi**3
7600         else
7601           difi=0.0
7602         endif
7603        if (energy_dec) then
7604         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",&
7605          i,itheta,rad2deg*thetiii,&
7606          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),&
7607          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,&
7608          gloc(itheta+nphi-2,icg)
7609         endif
7610       enddo
7611       return
7612       end subroutine etheta_constr
7613
7614 !-----------------------------------------------------------------------------
7615       subroutine eback_sc_corr(esccor)
7616 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
7617 !        conformational states; temporarily implemented as differences
7618 !        between UNRES torsional potentials (dependent on three types of
7619 !        residues) and the torsional potentials dependent on all 20 types
7620 !        of residues computed from AM1  energy surfaces of terminally-blocked
7621 !        amino-acid residues.
7622 !      implicit real*8 (a-h,o-z)
7623 !      include 'DIMENSIONS'
7624 !      include 'COMMON.VAR'
7625 !      include 'COMMON.GEO'
7626 !      include 'COMMON.LOCAL'
7627 !      include 'COMMON.TORSION'
7628 !      include 'COMMON.SCCOR'
7629 !      include 'COMMON.INTERACT'
7630 !      include 'COMMON.DERIV'
7631 !      include 'COMMON.CHAIN'
7632 !      include 'COMMON.NAMES'
7633 !      include 'COMMON.IOUNITS'
7634 !      include 'COMMON.FFIELD'
7635 !      include 'COMMON.CONTROL'
7636       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
7637                    cosphi,sinphi
7638       logical :: lprn
7639       integer :: i,interty,j,isccori,isccori1,intertyp
7640 ! Set lprn=.true. for debugging
7641       lprn=.false.
7642 !      lprn=.true.
7643 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7644       esccor=0.0D0
7645       do i=itau_start,itau_end
7646         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
7647         esccor_ii=0.0D0
7648         isccori=isccortyp(itype(i-2,1))
7649         isccori1=isccortyp(itype(i-1,1))
7650
7651 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7652         phii=phi(i)
7653         do intertyp=1,3 !intertyp
7654          esccor_ii=0.0D0
7655 !c Added 09 May 2012 (Adasko)
7656 !c  Intertyp means interaction type of backbone mainchain correlation:
7657 !   1 = SC...Ca...Ca...Ca
7658 !   2 = Ca...Ca...Ca...SC
7659 !   3 = SC...Ca...Ca...SCi
7660         gloci=0.0D0
7661         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
7662             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
7663             (itype(i-1,1).eq.ntyp1))) &
7664           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
7665            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
7666            .or.(itype(i,1).eq.ntyp1))) &
7667           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
7668             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
7669             (itype(i-3,1).eq.ntyp1)))) cycle
7670         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
7671         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
7672        cycle
7673        do j=1,nterm_sccor(isccori,isccori1)
7674           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7675           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7676           cosphi=dcos(j*tauangle(intertyp,i))
7677           sinphi=dsin(j*tauangle(intertyp,i))
7678           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7679           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7680           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7681         enddo
7682         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
7683                                 'esccor',i,intertyp,esccor_ii
7684 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7685         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7686         if (lprn) &
7687         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7688         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
7689         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
7690         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7691         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7692        enddo !intertyp
7693       enddo
7694
7695       return
7696       end subroutine eback_sc_corr
7697 !-----------------------------------------------------------------------------
7698       subroutine multibody(ecorr)
7699 ! This subroutine calculates multi-body contributions to energy following
7700 ! the idea of Skolnick et al. If side chains I and J make a contact and
7701 ! at the same time side chains I+1 and J+1 make a contact, an extra
7702 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7703 !      implicit real*8 (a-h,o-z)
7704 !      include 'DIMENSIONS'
7705 !      include 'COMMON.IOUNITS'
7706 !      include 'COMMON.DERIV'
7707 !      include 'COMMON.INTERACT'
7708 !      include 'COMMON.CONTACTS'
7709       real(kind=8),dimension(3) :: gx,gx1
7710       logical :: lprn
7711       real(kind=8) :: ecorr
7712       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
7713 ! Set lprn=.true. for debugging
7714       lprn=.false.
7715
7716       if (lprn) then
7717         write (iout,'(a)') 'Contact function values:'
7718         do i=nnt,nct-2
7719           write (iout,'(i2,20(1x,i2,f10.5))') &
7720               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7721         enddo
7722       endif
7723       ecorr=0.0D0
7724
7725 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7726 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7727       do i=nnt,nct
7728         do j=1,3
7729           gradcorr(j,i)=0.0D0
7730           gradxorr(j,i)=0.0D0
7731         enddo
7732       enddo
7733       do i=nnt,nct-2
7734
7735         DO ISHIFT = 3,4
7736
7737         i1=i+ishift
7738         num_conti=num_cont(i)
7739         num_conti1=num_cont(i1)
7740         do jj=1,num_conti
7741           j=jcont(jj,i)
7742           do kk=1,num_conti1
7743             j1=jcont(kk,i1)
7744             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7745 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7746 !d   &                   ' ishift=',ishift
7747 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7748 ! The system gains extra energy.
7749               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7750             endif   ! j1==j+-ishift
7751           enddo     ! kk
7752         enddo       ! jj
7753
7754         ENDDO ! ISHIFT
7755
7756       enddo         ! i
7757       return
7758       end subroutine multibody
7759 !-----------------------------------------------------------------------------
7760       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7761 !      implicit real*8 (a-h,o-z)
7762 !      include 'DIMENSIONS'
7763 !      include 'COMMON.IOUNITS'
7764 !      include 'COMMON.DERIV'
7765 !      include 'COMMON.INTERACT'
7766 !      include 'COMMON.CONTACTS'
7767       real(kind=8),dimension(3) :: gx,gx1
7768       logical :: lprn
7769       integer :: i,j,k,l,jj,kk,m,ll
7770       real(kind=8) :: eij,ekl
7771       lprn=.false.
7772       eij=facont(jj,i)
7773       ekl=facont(kk,k)
7774 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7775 ! Calculate the multi-body contribution to energy.
7776 ! Calculate multi-body contributions to the gradient.
7777 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7778 !d   & k,l,(gacont(m,kk,k),m=1,3)
7779       do m=1,3
7780         gx(m) =ekl*gacont(m,jj,i)
7781         gx1(m)=eij*gacont(m,kk,k)
7782         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7783         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7784         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7785         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7786       enddo
7787       do m=i,j-1
7788         do ll=1,3
7789           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7790         enddo
7791       enddo
7792       do m=k,l-1
7793         do ll=1,3
7794           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7795         enddo
7796       enddo
7797       esccorr=-eij*ekl
7798       return
7799       end function esccorr
7800 !-----------------------------------------------------------------------------
7801       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7802 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7803 !      implicit real*8 (a-h,o-z)
7804 !      include 'DIMENSIONS'
7805 !      include 'COMMON.IOUNITS'
7806 #ifdef MPI
7807       include "mpif.h"
7808 !      integer :: maxconts !max_cont=maxconts  =nres/4
7809       integer,parameter :: max_dim=26
7810       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7811       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7812 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7813 !el      common /przechowalnia/ zapas
7814       integer :: status(MPI_STATUS_SIZE)
7815       integer,dimension((nres/4)*2) :: req !maxconts*2
7816       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7817 #endif
7818 !      include 'COMMON.SETUP'
7819 !      include 'COMMON.FFIELD'
7820 !      include 'COMMON.DERIV'
7821 !      include 'COMMON.INTERACT'
7822 !      include 'COMMON.CONTACTS'
7823 !      include 'COMMON.CONTROL'
7824 !      include 'COMMON.LOCAL'
7825       real(kind=8),dimension(3) :: gx,gx1
7826       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7827       logical :: lprn,ldone
7828 !el local variables
7829       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7830               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7831
7832 ! Set lprn=.true. for debugging
7833       lprn=.false.
7834 #ifdef MPI
7835 !      maxconts=nres/4
7836       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7837       n_corr=0
7838       n_corr1=0
7839       if (nfgtasks.le.1) goto 30
7840       if (lprn) then
7841         write (iout,'(a)') 'Contact function values before RECEIVE:'
7842         do i=nnt,nct-2
7843           write (iout,'(2i3,50(1x,i2,f5.2))') &
7844           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7845           j=1,num_cont_hb(i))
7846         enddo
7847       endif
7848       call flush(iout)
7849       do i=1,ntask_cont_from
7850         ncont_recv(i)=0
7851       enddo
7852       do i=1,ntask_cont_to
7853         ncont_sent(i)=0
7854       enddo
7855 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7856 !     & ntask_cont_to
7857 ! Make the list of contacts to send to send to other procesors
7858 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7859 !      call flush(iout)
7860       do i=iturn3_start,iturn3_end
7861 !        write (iout,*) "make contact list turn3",i," num_cont",
7862 !     &    num_cont_hb(i)
7863         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7864       enddo
7865       do i=iturn4_start,iturn4_end
7866 !        write (iout,*) "make contact list turn4",i," num_cont",
7867 !     &   num_cont_hb(i)
7868         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7869       enddo
7870       do ii=1,nat_sent
7871         i=iat_sent(ii)
7872 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7873 !     &    num_cont_hb(i)
7874         do j=1,num_cont_hb(i)
7875         do k=1,4
7876           jjc=jcont_hb(j,i)
7877           iproc=iint_sent_local(k,jjc,ii)
7878 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7879           if (iproc.gt.0) then
7880             ncont_sent(iproc)=ncont_sent(iproc)+1
7881             nn=ncont_sent(iproc)
7882             zapas(1,nn,iproc)=i
7883             zapas(2,nn,iproc)=jjc
7884             zapas(3,nn,iproc)=facont_hb(j,i)
7885             zapas(4,nn,iproc)=ees0p(j,i)
7886             zapas(5,nn,iproc)=ees0m(j,i)
7887             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7888             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7889             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7890             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7891             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7892             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7893             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7894             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7895             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7896             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7897             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7898             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7899             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7900             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7901             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7902             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7903             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7904             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7905             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7906             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7907             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7908           endif
7909         enddo
7910         enddo
7911       enddo
7912       if (lprn) then
7913       write (iout,*) &
7914         "Numbers of contacts to be sent to other processors",&
7915         (ncont_sent(i),i=1,ntask_cont_to)
7916       write (iout,*) "Contacts sent"
7917       do ii=1,ntask_cont_to
7918         nn=ncont_sent(ii)
7919         iproc=itask_cont_to(ii)
7920         write (iout,*) nn," contacts to processor",iproc,&
7921          " of CONT_TO_COMM group"
7922         do i=1,nn
7923           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7924         enddo
7925       enddo
7926       call flush(iout)
7927       endif
7928       CorrelType=477
7929       CorrelID=fg_rank+1
7930       CorrelType1=478
7931       CorrelID1=nfgtasks+fg_rank+1
7932       ireq=0
7933 ! Receive the numbers of needed contacts from other processors
7934       do ii=1,ntask_cont_from
7935         iproc=itask_cont_from(ii)
7936         ireq=ireq+1
7937         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7938           FG_COMM,req(ireq),IERR)
7939       enddo
7940 !      write (iout,*) "IRECV ended"
7941 !      call flush(iout)
7942 ! Send the number of contacts needed by other processors
7943       do ii=1,ntask_cont_to
7944         iproc=itask_cont_to(ii)
7945         ireq=ireq+1
7946         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7947           FG_COMM,req(ireq),IERR)
7948       enddo
7949 !      write (iout,*) "ISEND ended"
7950 !      write (iout,*) "number of requests (nn)",ireq
7951       call flush(iout)
7952       if (ireq.gt.0) &
7953         call MPI_Waitall(ireq,req,status_array,ierr)
7954 !      write (iout,*)
7955 !     &  "Numbers of contacts to be received from other processors",
7956 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7957 !      call flush(iout)
7958 ! Receive contacts
7959       ireq=0
7960       do ii=1,ntask_cont_from
7961         iproc=itask_cont_from(ii)
7962         nn=ncont_recv(ii)
7963 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7964 !     &   " of CONT_TO_COMM group"
7965         call flush(iout)
7966         if (nn.gt.0) then
7967           ireq=ireq+1
7968           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7969           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7970 !          write (iout,*) "ireq,req",ireq,req(ireq)
7971         endif
7972       enddo
7973 ! Send the contacts to processors that need them
7974       do ii=1,ntask_cont_to
7975         iproc=itask_cont_to(ii)
7976         nn=ncont_sent(ii)
7977 !        write (iout,*) nn," contacts to processor",iproc,
7978 !     &   " of CONT_TO_COMM group"
7979         if (nn.gt.0) then
7980           ireq=ireq+1
7981           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7982             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7983 !          write (iout,*) "ireq,req",ireq,req(ireq)
7984 !          do i=1,nn
7985 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7986 !          enddo
7987         endif
7988       enddo
7989 !      write (iout,*) "number of requests (contacts)",ireq
7990 !      write (iout,*) "req",(req(i),i=1,4)
7991 !      call flush(iout)
7992       if (ireq.gt.0) &
7993        call MPI_Waitall(ireq,req,status_array,ierr)
7994       do iii=1,ntask_cont_from
7995         iproc=itask_cont_from(iii)
7996         nn=ncont_recv(iii)
7997         if (lprn) then
7998         write (iout,*) "Received",nn," contacts from processor",iproc,&
7999          " of CONT_FROM_COMM group"
8000         call flush(iout)
8001         do i=1,nn
8002           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8003         enddo
8004         call flush(iout)
8005         endif
8006         do i=1,nn
8007           ii=zapas_recv(1,i,iii)
8008 ! Flag the received contacts to prevent double-counting
8009           jj=-zapas_recv(2,i,iii)
8010 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8011 !          call flush(iout)
8012           nnn=num_cont_hb(ii)+1
8013           num_cont_hb(ii)=nnn
8014           jcont_hb(nnn,ii)=jj
8015           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8016           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8017           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8018           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8019           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8020           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8021           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8022           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8023           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8024           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8025           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8026           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8027           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8028           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8029           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8030           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8031           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8032           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8033           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8034           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8035           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8036           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8037           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8038           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8039         enddo
8040       enddo
8041       call flush(iout)
8042       if (lprn) then
8043         write (iout,'(a)') 'Contact function values after receive:'
8044         do i=nnt,nct-2
8045           write (iout,'(2i3,50(1x,i3,f5.2))') &
8046           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8047           j=1,num_cont_hb(i))
8048         enddo
8049         call flush(iout)
8050       endif
8051    30 continue
8052 #endif
8053       if (lprn) then
8054         write (iout,'(a)') 'Contact function values:'
8055         do i=nnt,nct-2
8056           write (iout,'(2i3,50(1x,i3,f5.2))') &
8057           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8058           j=1,num_cont_hb(i))
8059         enddo
8060       endif
8061       ecorr=0.0D0
8062
8063 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8064 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8065 ! Remove the loop below after debugging !!!
8066       do i=nnt,nct
8067         do j=1,3
8068           gradcorr(j,i)=0.0D0
8069           gradxorr(j,i)=0.0D0
8070         enddo
8071       enddo
8072 ! Calculate the local-electrostatic correlation terms
8073       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8074         i1=i+1
8075         num_conti=num_cont_hb(i)
8076         num_conti1=num_cont_hb(i+1)
8077         do jj=1,num_conti
8078           j=jcont_hb(jj,i)
8079           jp=iabs(j)
8080           do kk=1,num_conti1
8081             j1=jcont_hb(kk,i1)
8082             jp1=iabs(j1)
8083 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
8084 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
8085             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8086                 .or. j.lt.0 .and. j1.gt.0) .and. &
8087                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8088 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8089 ! The system gains extra energy.
8090               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8091               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
8092                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8093               n_corr=n_corr+1
8094             else if (j1.eq.j) then
8095 ! Contacts I-J and I-(J+1) occur simultaneously.
8096 ! The system loses extra energy.
8097 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8098             endif
8099           enddo ! kk
8100           do kk=1,num_conti
8101             j1=jcont_hb(kk,i)
8102 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8103 !    &         ' jj=',jj,' kk=',kk
8104             if (j1.eq.j+1) then
8105 ! Contacts I-J and (I+1)-J occur simultaneously.
8106 ! The system loses extra energy.
8107 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8108             endif ! j1==j+1
8109           enddo ! kk
8110         enddo ! jj
8111       enddo ! i
8112       return
8113       end subroutine multibody_hb
8114 !-----------------------------------------------------------------------------
8115       subroutine add_hb_contact(ii,jj,itask)
8116 !      implicit real*8 (a-h,o-z)
8117 !      include "DIMENSIONS"
8118 !      include "COMMON.IOUNITS"
8119 !      include "COMMON.CONTACTS"
8120 !      integer,parameter :: maxconts=nres/4
8121       integer,parameter :: max_dim=26
8122       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8123 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
8124 !      common /przechowalnia/ zapas
8125       integer :: i,j,ii,jj,iproc,nn,jjc
8126       integer,dimension(4) :: itask
8127 !      write (iout,*) "itask",itask
8128       do i=1,2
8129         iproc=itask(i)
8130         if (iproc.gt.0) then
8131           do j=1,num_cont_hb(ii)
8132             jjc=jcont_hb(j,ii)
8133 !            write (iout,*) "i",ii," j",jj," jjc",jjc
8134             if (jjc.eq.jj) then
8135               ncont_sent(iproc)=ncont_sent(iproc)+1
8136               nn=ncont_sent(iproc)
8137               zapas(1,nn,iproc)=ii
8138               zapas(2,nn,iproc)=jjc
8139               zapas(3,nn,iproc)=facont_hb(j,ii)
8140               zapas(4,nn,iproc)=ees0p(j,ii)
8141               zapas(5,nn,iproc)=ees0m(j,ii)
8142               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8143               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8144               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8145               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8146               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8147               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8148               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8149               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8150               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8151               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8152               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8153               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8154               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8155               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8156               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8157               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8158               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8159               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8160               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8161               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8162               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8163               exit
8164             endif
8165           enddo
8166         endif
8167       enddo
8168       return
8169       end subroutine add_hb_contact
8170 !-----------------------------------------------------------------------------
8171       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
8172 ! This subroutine calculates multi-body contributions to hydrogen-bonding
8173 !      implicit real*8 (a-h,o-z)
8174 !      include 'DIMENSIONS'
8175 !      include 'COMMON.IOUNITS'
8176       integer,parameter :: max_dim=70
8177 #ifdef MPI
8178       include "mpif.h"
8179 !      integer :: maxconts !max_cont=maxconts=nres/4
8180       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8181       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8182 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8183 !      common /przechowalnia/ zapas
8184       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
8185         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
8186         ierr,iii,nnn
8187 #endif
8188 !      include 'COMMON.SETUP'
8189 !      include 'COMMON.FFIELD'
8190 !      include 'COMMON.DERIV'
8191 !      include 'COMMON.LOCAL'
8192 !      include 'COMMON.INTERACT'
8193 !      include 'COMMON.CONTACTS'
8194 !      include 'COMMON.CHAIN'
8195 !      include 'COMMON.CONTROL'
8196       real(kind=8),dimension(3) :: gx,gx1
8197       integer,dimension(nres) :: num_cont_hb_old
8198       logical :: lprn,ldone
8199 !EL      double precision eello4,eello5,eelo6,eello_turn6
8200 !EL      external eello4,eello5,eello6,eello_turn6
8201 !el local variables
8202       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
8203               j1,jp1,i1,num_conti1
8204       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
8205       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
8206
8207 ! Set lprn=.true. for debugging
8208       lprn=.false.
8209       eturn6=0.0d0
8210 #ifdef MPI
8211 !      maxconts=nres/4
8212       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
8213       do i=1,nres
8214         num_cont_hb_old(i)=num_cont_hb(i)
8215       enddo
8216       n_corr=0
8217       n_corr1=0
8218       if (nfgtasks.le.1) goto 30
8219       if (lprn) then
8220         write (iout,'(a)') 'Contact function values before RECEIVE:'
8221         do i=nnt,nct-2
8222           write (iout,'(2i3,50(1x,i2,f5.2))') &
8223           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8224           j=1,num_cont_hb(i))
8225         enddo
8226       endif
8227       call flush(iout)
8228       do i=1,ntask_cont_from
8229         ncont_recv(i)=0
8230       enddo
8231       do i=1,ntask_cont_to
8232         ncont_sent(i)=0
8233       enddo
8234 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8235 !     & ntask_cont_to
8236 ! Make the list of contacts to send to send to other procesors
8237       do i=iturn3_start,iturn3_end
8238 !        write (iout,*) "make contact list turn3",i," num_cont",
8239 !     &    num_cont_hb(i)
8240         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8241       enddo
8242       do i=iturn4_start,iturn4_end
8243 !        write (iout,*) "make contact list turn4",i," num_cont",
8244 !     &   num_cont_hb(i)
8245         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8246       enddo
8247       do ii=1,nat_sent
8248         i=iat_sent(ii)
8249 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8250 !     &    num_cont_hb(i)
8251         do j=1,num_cont_hb(i)
8252         do k=1,4
8253           jjc=jcont_hb(j,i)
8254           iproc=iint_sent_local(k,jjc,ii)
8255 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8256           if (iproc.ne.0) then
8257             ncont_sent(iproc)=ncont_sent(iproc)+1
8258             nn=ncont_sent(iproc)
8259             zapas(1,nn,iproc)=i
8260             zapas(2,nn,iproc)=jjc
8261             zapas(3,nn,iproc)=d_cont(j,i)
8262             ind=3
8263             do kk=1,3
8264               ind=ind+1
8265               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8266             enddo
8267             do kk=1,2
8268               do ll=1,2
8269                 ind=ind+1
8270                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8271               enddo
8272             enddo
8273             do jj=1,5
8274               do kk=1,3
8275                 do ll=1,2
8276                   do mm=1,2
8277                     ind=ind+1
8278                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8279                   enddo
8280                 enddo
8281               enddo
8282             enddo
8283           endif
8284         enddo
8285         enddo
8286       enddo
8287       if (lprn) then
8288       write (iout,*) &
8289         "Numbers of contacts to be sent to other processors",&
8290         (ncont_sent(i),i=1,ntask_cont_to)
8291       write (iout,*) "Contacts sent"
8292       do ii=1,ntask_cont_to
8293         nn=ncont_sent(ii)
8294         iproc=itask_cont_to(ii)
8295         write (iout,*) nn," contacts to processor",iproc,&
8296          " of CONT_TO_COMM group"
8297         do i=1,nn
8298           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8299         enddo
8300       enddo
8301       call flush(iout)
8302       endif
8303       CorrelType=477
8304       CorrelID=fg_rank+1
8305       CorrelType1=478
8306       CorrelID1=nfgtasks+fg_rank+1
8307       ireq=0
8308 ! Receive the numbers of needed contacts from other processors
8309       do ii=1,ntask_cont_from
8310         iproc=itask_cont_from(ii)
8311         ireq=ireq+1
8312         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8313           FG_COMM,req(ireq),IERR)
8314       enddo
8315 !      write (iout,*) "IRECV ended"
8316 !      call flush(iout)
8317 ! Send the number of contacts needed by other processors
8318       do ii=1,ntask_cont_to
8319         iproc=itask_cont_to(ii)
8320         ireq=ireq+1
8321         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8322           FG_COMM,req(ireq),IERR)
8323       enddo
8324 !      write (iout,*) "ISEND ended"
8325 !      write (iout,*) "number of requests (nn)",ireq
8326       call flush(iout)
8327       if (ireq.gt.0) &
8328         call MPI_Waitall(ireq,req,status_array,ierr)
8329 !      write (iout,*)
8330 !     &  "Numbers of contacts to be received from other processors",
8331 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8332 !      call flush(iout)
8333 ! Receive contacts
8334       ireq=0
8335       do ii=1,ntask_cont_from
8336         iproc=itask_cont_from(ii)
8337         nn=ncont_recv(ii)
8338 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8339 !     &   " of CONT_TO_COMM group"
8340         call flush(iout)
8341         if (nn.gt.0) then
8342           ireq=ireq+1
8343           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
8344           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8345 !          write (iout,*) "ireq,req",ireq,req(ireq)
8346         endif
8347       enddo
8348 ! Send the contacts to processors that need them
8349       do ii=1,ntask_cont_to
8350         iproc=itask_cont_to(ii)
8351         nn=ncont_sent(ii)
8352 !        write (iout,*) nn," contacts to processor",iproc,
8353 !     &   " of CONT_TO_COMM group"
8354         if (nn.gt.0) then
8355           ireq=ireq+1
8356           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8357             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8358 !          write (iout,*) "ireq,req",ireq,req(ireq)
8359 !          do i=1,nn
8360 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8361 !          enddo
8362         endif
8363       enddo
8364 !      write (iout,*) "number of requests (contacts)",ireq
8365 !      write (iout,*) "req",(req(i),i=1,4)
8366 !      call flush(iout)
8367       if (ireq.gt.0) &
8368        call MPI_Waitall(ireq,req,status_array,ierr)
8369       do iii=1,ntask_cont_from
8370         iproc=itask_cont_from(iii)
8371         nn=ncont_recv(iii)
8372         if (lprn) then
8373         write (iout,*) "Received",nn," contacts from processor",iproc,&
8374          " of CONT_FROM_COMM group"
8375         call flush(iout)
8376         do i=1,nn
8377           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8378         enddo
8379         call flush(iout)
8380         endif
8381         do i=1,nn
8382           ii=zapas_recv(1,i,iii)
8383 ! Flag the received contacts to prevent double-counting
8384           jj=-zapas_recv(2,i,iii)
8385 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8386 !          call flush(iout)
8387           nnn=num_cont_hb(ii)+1
8388           num_cont_hb(ii)=nnn
8389           jcont_hb(nnn,ii)=jj
8390           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8391           ind=3
8392           do kk=1,3
8393             ind=ind+1
8394             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8395           enddo
8396           do kk=1,2
8397             do ll=1,2
8398               ind=ind+1
8399               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8400             enddo
8401           enddo
8402           do jj=1,5
8403             do kk=1,3
8404               do ll=1,2
8405                 do mm=1,2
8406                   ind=ind+1
8407                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8408                 enddo
8409               enddo
8410             enddo
8411           enddo
8412         enddo
8413       enddo
8414       call flush(iout)
8415       if (lprn) then
8416         write (iout,'(a)') 'Contact function values after receive:'
8417         do i=nnt,nct-2
8418           write (iout,'(2i3,50(1x,i3,5f6.3))') &
8419           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8420           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8421         enddo
8422         call flush(iout)
8423       endif
8424    30 continue
8425 #endif
8426       if (lprn) then
8427         write (iout,'(a)') 'Contact function values:'
8428         do i=nnt,nct-2
8429           write (iout,'(2i3,50(1x,i2,5f6.3))') &
8430           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8431           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8432         enddo
8433       endif
8434       ecorr=0.0D0
8435       ecorr5=0.0d0
8436       ecorr6=0.0d0
8437
8438 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8439 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8440 ! Remove the loop below after debugging !!!
8441       do i=nnt,nct
8442         do j=1,3
8443           gradcorr(j,i)=0.0D0
8444           gradxorr(j,i)=0.0D0
8445         enddo
8446       enddo
8447 ! Calculate the dipole-dipole interaction energies
8448       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8449       do i=iatel_s,iatel_e+1
8450         num_conti=num_cont_hb(i)
8451         do jj=1,num_conti
8452           j=jcont_hb(jj,i)
8453 #ifdef MOMENT
8454           call dipole(i,j,jj)
8455 #endif
8456         enddo
8457       enddo
8458       endif
8459 ! Calculate the local-electrostatic correlation terms
8460 !                write (iout,*) "gradcorr5 in eello5 before loop"
8461 !                do iii=1,nres
8462 !                  write (iout,'(i5,3f10.5)')
8463 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8464 !                enddo
8465       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8466 !        write (iout,*) "corr loop i",i
8467         i1=i+1
8468         num_conti=num_cont_hb(i)
8469         num_conti1=num_cont_hb(i+1)
8470         do jj=1,num_conti
8471           j=jcont_hb(jj,i)
8472           jp=iabs(j)
8473           do kk=1,num_conti1
8474             j1=jcont_hb(kk,i1)
8475             jp1=iabs(j1)
8476 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8477 !     &         ' jj=',jj,' kk=',kk
8478 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
8479             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8480                 .or. j.lt.0 .and. j1.gt.0) .and. &
8481                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8482 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8483 ! The system gains extra energy.
8484               n_corr=n_corr+1
8485               sqd1=dsqrt(d_cont(jj,i))
8486               sqd2=dsqrt(d_cont(kk,i1))
8487               sred_geom = sqd1*sqd2
8488               IF (sred_geom.lt.cutoff_corr) THEN
8489                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
8490                   ekont,fprimcont)
8491 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8492 !d     &         ' jj=',jj,' kk=',kk
8493                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8494                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8495                 do l=1,3
8496                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8497                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8498                 enddo
8499                 n_corr1=n_corr1+1
8500 !d               write (iout,*) 'sred_geom=',sred_geom,
8501 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
8502 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8503 !d               write (iout,*) "g_contij",g_contij
8504 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8505 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8506                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8507                 if (wcorr4.gt.0.0d0) &
8508                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8509                   if (energy_dec.and.wcorr4.gt.0.0d0) &
8510                        write (iout,'(a6,4i5,0pf7.3)') &
8511                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8512 !                write (iout,*) "gradcorr5 before eello5"
8513 !                do iii=1,nres
8514 !                  write (iout,'(i5,3f10.5)')
8515 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8516 !                enddo
8517                 if (wcorr5.gt.0.0d0) &
8518                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8519 !                write (iout,*) "gradcorr5 after eello5"
8520 !                do iii=1,nres
8521 !                  write (iout,'(i5,3f10.5)')
8522 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8523 !                enddo
8524                   if (energy_dec.and.wcorr5.gt.0.0d0) &
8525                        write (iout,'(a6,4i5,0pf7.3)') &
8526                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8527 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8528 !d                write(2,*)'ijkl',i,jp,i+1,jp1
8529                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
8530                      .or. wturn6.eq.0.0d0))then
8531 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8532                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8533                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8534                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8535 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8536 !d     &            'ecorr6=',ecorr6
8537 !d                write (iout,'(4e15.5)') sred_geom,
8538 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8539 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8540 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8541                 else if (wturn6.gt.0.0d0 &
8542                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8543 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8544                   eturn6=eturn6+eello_turn6(i,jj,kk)
8545                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8546                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8547 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
8548                 endif
8549               ENDIF
8550 1111          continue
8551             endif
8552           enddo ! kk
8553         enddo ! jj
8554       enddo ! i
8555       do i=1,nres
8556         num_cont_hb(i)=num_cont_hb_old(i)
8557       enddo
8558 !                write (iout,*) "gradcorr5 in eello5"
8559 !                do iii=1,nres
8560 !                  write (iout,'(i5,3f10.5)')
8561 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8562 !                enddo
8563       return
8564       end subroutine multibody_eello
8565 !-----------------------------------------------------------------------------
8566       subroutine add_hb_contact_eello(ii,jj,itask)
8567 !      implicit real*8 (a-h,o-z)
8568 !      include "DIMENSIONS"
8569 !      include "COMMON.IOUNITS"
8570 !      include "COMMON.CONTACTS"
8571 !      integer,parameter :: maxconts=nres/4
8572       integer,parameter :: max_dim=70
8573       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8574 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8575 !      common /przechowalnia/ zapas
8576
8577       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
8578       integer,dimension(4) ::itask
8579 !      write (iout,*) "itask",itask
8580       do i=1,2
8581         iproc=itask(i)
8582         if (iproc.gt.0) then
8583           do j=1,num_cont_hb(ii)
8584             jjc=jcont_hb(j,ii)
8585 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8586             if (jjc.eq.jj) then
8587               ncont_sent(iproc)=ncont_sent(iproc)+1
8588               nn=ncont_sent(iproc)
8589               zapas(1,nn,iproc)=ii
8590               zapas(2,nn,iproc)=jjc
8591               zapas(3,nn,iproc)=d_cont(j,ii)
8592               ind=3
8593               do kk=1,3
8594                 ind=ind+1
8595                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8596               enddo
8597               do kk=1,2
8598                 do ll=1,2
8599                   ind=ind+1
8600                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8601                 enddo
8602               enddo
8603               do jj=1,5
8604                 do kk=1,3
8605                   do ll=1,2
8606                     do mm=1,2
8607                       ind=ind+1
8608                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8609                     enddo
8610                   enddo
8611                 enddo
8612               enddo
8613               exit
8614             endif
8615           enddo
8616         endif
8617       enddo
8618       return
8619       end subroutine add_hb_contact_eello
8620 !-----------------------------------------------------------------------------
8621       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8622 !      implicit real*8 (a-h,o-z)
8623 !      include 'DIMENSIONS'
8624 !      include 'COMMON.IOUNITS'
8625 !      include 'COMMON.DERIV'
8626 !      include 'COMMON.INTERACT'
8627 !      include 'COMMON.CONTACTS'
8628       real(kind=8),dimension(3) :: gx,gx1
8629       logical :: lprn
8630 !el local variables
8631       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
8632       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
8633                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
8634                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
8635                    rlocshield
8636
8637       lprn=.false.
8638       eij=facont_hb(jj,i)
8639       ekl=facont_hb(kk,k)
8640       ees0pij=ees0p(jj,i)
8641       ees0pkl=ees0p(kk,k)
8642       ees0mij=ees0m(jj,i)
8643       ees0mkl=ees0m(kk,k)
8644       ekont=eij*ekl
8645       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8646 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8647 ! Following 4 lines for diagnostics.
8648 !d    ees0pkl=0.0D0
8649 !d    ees0pij=1.0D0
8650 !d    ees0mkl=0.0D0
8651 !d    ees0mij=1.0D0
8652 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8653 !     & 'Contacts ',i,j,
8654 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8655 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8656 !     & 'gradcorr_long'
8657 ! Calculate the multi-body contribution to energy.
8658 !      ecorr=ecorr+ekont*ees
8659 ! Calculate multi-body contributions to the gradient.
8660       coeffpees0pij=coeffp*ees0pij
8661       coeffmees0mij=coeffm*ees0mij
8662       coeffpees0pkl=coeffp*ees0pkl
8663       coeffmees0mkl=coeffm*ees0mkl
8664       do ll=1,3
8665 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8666         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
8667         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
8668         coeffmees0mkl*gacontm_hb1(ll,jj,i))
8669         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
8670         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
8671         coeffmees0mkl*gacontm_hb2(ll,jj,i))
8672 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8673         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
8674         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
8675         coeffmees0mij*gacontm_hb1(ll,kk,k))
8676         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
8677         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
8678         coeffmees0mij*gacontm_hb2(ll,kk,k))
8679         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
8680            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
8681            coeffmees0mkl*gacontm_hb3(ll,jj,i))
8682         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8683         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8684         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
8685            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
8686            coeffmees0mij*gacontm_hb3(ll,kk,k))
8687         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8688         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8689 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8690       enddo
8691 !      write (iout,*)
8692 !grad      do m=i+1,j-1
8693 !grad        do ll=1,3
8694 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8695 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8696 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8697 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8698 !grad        enddo
8699 !grad      enddo
8700 !grad      do m=k+1,l-1
8701 !grad        do ll=1,3
8702 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8703 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
8704 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8705 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8706 !grad        enddo
8707 !grad      enddo
8708 !      write (iout,*) "ehbcorr",ekont*ees
8709       ehbcorr=ekont*ees
8710       if (shield_mode.gt.0) then
8711        j=ees0plist(jj,i)
8712        l=ees0plist(kk,k)
8713 !C        print *,i,j,fac_shield(i),fac_shield(j),
8714 !C     &fac_shield(k),fac_shield(l)
8715         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
8716            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8717           do ilist=1,ishield_list(i)
8718            iresshield=shield_list(ilist,i)
8719            do m=1,3
8720            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8721            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8722                    rlocshield  &
8723             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8724             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8725             +rlocshield
8726            enddo
8727           enddo
8728           do ilist=1,ishield_list(j)
8729            iresshield=shield_list(ilist,j)
8730            do m=1,3
8731            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8732            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8733                    rlocshield &
8734             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8735            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8736             +rlocshield
8737            enddo
8738           enddo
8739
8740           do ilist=1,ishield_list(k)
8741            iresshield=shield_list(ilist,k)
8742            do m=1,3
8743            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8744            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8745                    rlocshield &
8746             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8747            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8748             +rlocshield
8749            enddo
8750           enddo
8751           do ilist=1,ishield_list(l)
8752            iresshield=shield_list(ilist,l)
8753            do m=1,3
8754            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8755            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8756                    rlocshield &
8757             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8758            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8759             +rlocshield
8760            enddo
8761           enddo
8762           do m=1,3
8763             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8764                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8765             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8766                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8767             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8768                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8769             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8770                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8771
8772             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8773                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8774             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8775                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8776             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8777                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8778             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8779                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8780
8781            enddo
8782       endif
8783       endif
8784       return
8785       end function ehbcorr
8786 #ifdef MOMENT
8787 !-----------------------------------------------------------------------------
8788       subroutine dipole(i,j,jj)
8789 !      implicit real*8 (a-h,o-z)
8790 !      include 'DIMENSIONS'
8791 !      include 'COMMON.IOUNITS'
8792 !      include 'COMMON.CHAIN'
8793 !      include 'COMMON.FFIELD'
8794 !      include 'COMMON.DERIV'
8795 !      include 'COMMON.INTERACT'
8796 !      include 'COMMON.CONTACTS'
8797 !      include 'COMMON.TORSION'
8798 !      include 'COMMON.VAR'
8799 !      include 'COMMON.GEO'
8800       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8801       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8802       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8803
8804       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8805       allocate(dipderx(3,5,4,maxconts,nres))
8806 !
8807
8808       iti1 = itortyp(itype(i+1,1))
8809       if (j.lt.nres-1) then
8810         itj1 = itype2loc(itype(j+1,1))
8811       else
8812         itj1=nloctyp
8813       endif
8814       do iii=1,2
8815         dipi(iii,1)=Ub2(iii,i)
8816         dipderi(iii)=Ub2der(iii,i)
8817         dipi(iii,2)=b1(iii,iti1)
8818         dipj(iii,1)=Ub2(iii,j)
8819         dipderj(iii)=Ub2der(iii,j)
8820         dipj(iii,2)=b1(iii,itj1)
8821       enddo
8822       kkk=0
8823       do iii=1,2
8824         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8825         do jjj=1,2
8826           kkk=kkk+1
8827           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8828         enddo
8829       enddo
8830       do kkk=1,5
8831         do lll=1,3
8832           mmm=0
8833           do iii=1,2
8834             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8835               auxvec(1))
8836             do jjj=1,2
8837               mmm=mmm+1
8838               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8839             enddo
8840           enddo
8841         enddo
8842       enddo
8843       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8844       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8845       do iii=1,2
8846         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8847       enddo
8848       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8849       do iii=1,2
8850         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8851       enddo
8852       return
8853       end subroutine dipole
8854 #endif
8855 !-----------------------------------------------------------------------------
8856       subroutine calc_eello(i,j,k,l,jj,kk)
8857 !
8858 ! This subroutine computes matrices and vectors needed to calculate
8859 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
8860 !
8861       use comm_kut
8862 !      implicit real*8 (a-h,o-z)
8863 !      include 'DIMENSIONS'
8864 !      include 'COMMON.IOUNITS'
8865 !      include 'COMMON.CHAIN'
8866 !      include 'COMMON.DERIV'
8867 !      include 'COMMON.INTERACT'
8868 !      include 'COMMON.CONTACTS'
8869 !      include 'COMMON.TORSION'
8870 !      include 'COMMON.VAR'
8871 !      include 'COMMON.GEO'
8872 !      include 'COMMON.FFIELD'
8873       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
8874       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
8875       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
8876               itj1
8877 !el      logical :: lprn
8878 !el      common /kutas/ lprn
8879 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8880 !d     & ' jj=',jj,' kk=',kk
8881 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8882 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8883 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8884       do iii=1,2
8885         do jjj=1,2
8886           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8887           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8888         enddo
8889       enddo
8890       call transpose2(aa1(1,1),aa1t(1,1))
8891       call transpose2(aa2(1,1),aa2t(1,1))
8892       do kkk=1,5
8893         do lll=1,3
8894           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
8895             aa1tder(1,1,lll,kkk))
8896           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
8897             aa2tder(1,1,lll,kkk))
8898         enddo
8899       enddo
8900       if (l.eq.j+1) then
8901 ! parallel orientation of the two CA-CA-CA frames.
8902         if (i.gt.1) then
8903           iti=itortyp(itype(i,1))
8904         else
8905           iti=ntortyp+1
8906         endif
8907         itk1=itortyp(itype(k+1,1))
8908         itj=itortyp(itype(j,1))
8909         if (l.lt.nres-1) then
8910           itl1=itortyp(itype(l+1,1))
8911         else
8912           itl1=ntortyp+1
8913         endif
8914 ! A1 kernel(j+1) A2T
8915 !d        do iii=1,2
8916 !d          write (iout,'(3f10.5,5x,3f10.5)')
8917 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8918 !d        enddo
8919         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8920          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
8921          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8922 ! Following matrices are needed only for 6-th order cumulants
8923         IF (wcorr6.gt.0.0d0) THEN
8924         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8925          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
8926          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8927         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8928          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
8929          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8930          ADtEAderx(1,1,1,1,1,1))
8931         lprn=.false.
8932         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8933          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
8934          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8935          ADtEA1derx(1,1,1,1,1,1))
8936         ENDIF
8937 ! End 6-th order cumulants
8938 !d        lprn=.false.
8939 !d        if (lprn) then
8940 !d        write (2,*) 'In calc_eello6'
8941 !d        do iii=1,2
8942 !d          write (2,*) 'iii=',iii
8943 !d          do kkk=1,5
8944 !d            write (2,*) 'kkk=',kkk
8945 !d            do jjj=1,2
8946 !d              write (2,'(3(2f10.5),5x)')
8947 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8948 !d            enddo
8949 !d          enddo
8950 !d        enddo
8951 !d        endif
8952         call transpose2(EUgder(1,1,k),auxmat(1,1))
8953         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8954         call transpose2(EUg(1,1,k),auxmat(1,1))
8955         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8956         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8957         do iii=1,2
8958           do kkk=1,5
8959             do lll=1,3
8960               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8961                 EAEAderx(1,1,lll,kkk,iii,1))
8962             enddo
8963           enddo
8964         enddo
8965 ! A1T kernel(i+1) A2
8966         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8967          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
8968          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8969 ! Following matrices are needed only for 6-th order cumulants
8970         IF (wcorr6.gt.0.0d0) THEN
8971         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8972          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
8973          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8974         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8975          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
8976          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8977          ADtEAderx(1,1,1,1,1,2))
8978         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8979          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
8980          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8981          ADtEA1derx(1,1,1,1,1,2))
8982         ENDIF
8983 ! End 6-th order cumulants
8984         call transpose2(EUgder(1,1,l),auxmat(1,1))
8985         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8986         call transpose2(EUg(1,1,l),auxmat(1,1))
8987         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8988         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8989         do iii=1,2
8990           do kkk=1,5
8991             do lll=1,3
8992               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8993                 EAEAderx(1,1,lll,kkk,iii,2))
8994             enddo
8995           enddo
8996         enddo
8997 ! AEAb1 and AEAb2
8998 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8999 ! They are needed only when the fifth- or the sixth-order cumulants are
9000 ! indluded.
9001         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9002         call transpose2(AEA(1,1,1),auxmat(1,1))
9003         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9004         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9005         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9006         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9007         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9008         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9009         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9010         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9011         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9012         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9013         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9014         call transpose2(AEA(1,1,2),auxmat(1,1))
9015         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
9016         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9017         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9018         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9019         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
9020         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9021         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
9022         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
9023         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9024         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9025         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9026 ! Calculate the Cartesian derivatives of the vectors.
9027         do iii=1,2
9028           do kkk=1,5
9029             do lll=1,3
9030               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9031               call matvec2(auxmat(1,1),b1(1,iti),&
9032                 AEAb1derx(1,lll,kkk,iii,1,1))
9033               call matvec2(auxmat(1,1),Ub2(1,i),&
9034                 AEAb2derx(1,lll,kkk,iii,1,1))
9035               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9036                 AEAb1derx(1,lll,kkk,iii,2,1))
9037               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9038                 AEAb2derx(1,lll,kkk,iii,2,1))
9039               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9040               call matvec2(auxmat(1,1),b1(1,itj),&
9041                 AEAb1derx(1,lll,kkk,iii,1,2))
9042               call matvec2(auxmat(1,1),Ub2(1,j),&
9043                 AEAb2derx(1,lll,kkk,iii,1,2))
9044               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9045                 AEAb1derx(1,lll,kkk,iii,2,2))
9046               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
9047                 AEAb2derx(1,lll,kkk,iii,2,2))
9048             enddo
9049           enddo
9050         enddo
9051         ENDIF
9052 ! End vectors
9053       else
9054 ! Antiparallel orientation of the two CA-CA-CA frames.
9055         if (i.gt.1) then
9056           iti=itortyp(itype(i,1))
9057         else
9058           iti=ntortyp+1
9059         endif
9060         itk1=itortyp(itype(k+1,1))
9061         itl=itortyp(itype(l,1))
9062         itj=itortyp(itype(j,1))
9063         if (j.lt.nres-1) then
9064           itj1=itortyp(itype(j+1,1))
9065         else
9066           itj1=ntortyp+1
9067         endif
9068 ! A2 kernel(j-1)T A1T
9069         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9070          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
9071          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9072 ! Following matrices are needed only for 6-th order cumulants
9073         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9074            j.eq.i+4 .and. l.eq.i+3)) THEN
9075         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9076          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
9077          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9078         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9079          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
9080          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9081          ADtEAderx(1,1,1,1,1,1))
9082         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9083          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
9084          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9085          ADtEA1derx(1,1,1,1,1,1))
9086         ENDIF
9087 ! End 6-th order cumulants
9088         call transpose2(EUgder(1,1,k),auxmat(1,1))
9089         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9090         call transpose2(EUg(1,1,k),auxmat(1,1))
9091         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9092         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9093         do iii=1,2
9094           do kkk=1,5
9095             do lll=1,3
9096               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9097                 EAEAderx(1,1,lll,kkk,iii,1))
9098             enddo
9099           enddo
9100         enddo
9101 ! A2T kernel(i+1)T A1
9102         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9103          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
9104          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9105 ! Following matrices are needed only for 6-th order cumulants
9106         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9107            j.eq.i+4 .and. l.eq.i+3)) THEN
9108         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9109          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
9110          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9111         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9112          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
9113          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9114          ADtEAderx(1,1,1,1,1,2))
9115         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9116          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
9117          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9118          ADtEA1derx(1,1,1,1,1,2))
9119         ENDIF
9120 ! End 6-th order cumulants
9121         call transpose2(EUgder(1,1,j),auxmat(1,1))
9122         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9123         call transpose2(EUg(1,1,j),auxmat(1,1))
9124         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9125         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9126         do iii=1,2
9127           do kkk=1,5
9128             do lll=1,3
9129               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9130                 EAEAderx(1,1,lll,kkk,iii,2))
9131             enddo
9132           enddo
9133         enddo
9134 ! AEAb1 and AEAb2
9135 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9136 ! They are needed only when the fifth- or the sixth-order cumulants are
9137 ! indluded.
9138         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
9139           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9140         call transpose2(AEA(1,1,1),auxmat(1,1))
9141         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9142         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9143         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9144         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9145         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9146         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9147         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9148         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9149         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9150         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9151         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9152         call transpose2(AEA(1,1,2),auxmat(1,1))
9153         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
9154         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9155         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9156         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9157         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
9158         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9159         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
9160         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
9161         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9162         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9163         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9164 ! Calculate the Cartesian derivatives of the vectors.
9165         do iii=1,2
9166           do kkk=1,5
9167             do lll=1,3
9168               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9169               call matvec2(auxmat(1,1),b1(1,iti),&
9170                 AEAb1derx(1,lll,kkk,iii,1,1))
9171               call matvec2(auxmat(1,1),Ub2(1,i),&
9172                 AEAb2derx(1,lll,kkk,iii,1,1))
9173               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9174                 AEAb1derx(1,lll,kkk,iii,2,1))
9175               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9176                 AEAb2derx(1,lll,kkk,iii,2,1))
9177               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9178               call matvec2(auxmat(1,1),b1(1,itl),&
9179                 AEAb1derx(1,lll,kkk,iii,1,2))
9180               call matvec2(auxmat(1,1),Ub2(1,l),&
9181                 AEAb2derx(1,lll,kkk,iii,1,2))
9182               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
9183                 AEAb1derx(1,lll,kkk,iii,2,2))
9184               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
9185                 AEAb2derx(1,lll,kkk,iii,2,2))
9186             enddo
9187           enddo
9188         enddo
9189         ENDIF
9190 ! End vectors
9191       endif
9192       return
9193       end subroutine calc_eello
9194 !-----------------------------------------------------------------------------
9195       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
9196       use comm_kut
9197       implicit none
9198       integer :: nderg
9199       logical :: transp
9200       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
9201       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
9202       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
9203       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
9204       integer :: iii,kkk,lll
9205       integer :: jjj,mmm
9206 !el      logical :: lprn
9207 !el      common /kutas/ lprn
9208       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9209       do iii=1,nderg
9210         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
9211           AKAderg(1,1,iii))
9212       enddo
9213 !d      if (lprn) write (2,*) 'In kernel'
9214       do kkk=1,5
9215 !d        if (lprn) write (2,*) 'kkk=',kkk
9216         do lll=1,3
9217           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
9218             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9219 !d          if (lprn) then
9220 !d            write (2,*) 'lll=',lll
9221 !d            write (2,*) 'iii=1'
9222 !d            do jjj=1,2
9223 !d              write (2,'(3(2f10.5),5x)')
9224 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9225 !d            enddo
9226 !d          endif
9227           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
9228             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9229 !d          if (lprn) then
9230 !d            write (2,*) 'lll=',lll
9231 !d            write (2,*) 'iii=2'
9232 !d            do jjj=1,2
9233 !d              write (2,'(3(2f10.5),5x)')
9234 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9235 !d            enddo
9236 !d          endif
9237         enddo
9238       enddo
9239       return
9240       end subroutine kernel
9241 !-----------------------------------------------------------------------------
9242       real(kind=8) function eello4(i,j,k,l,jj,kk)
9243 !      implicit real*8 (a-h,o-z)
9244 !      include 'DIMENSIONS'
9245 !      include 'COMMON.IOUNITS'
9246 !      include 'COMMON.CHAIN'
9247 !      include 'COMMON.DERIV'
9248 !      include 'COMMON.INTERACT'
9249 !      include 'COMMON.CONTACTS'
9250 !      include 'COMMON.TORSION'
9251 !      include 'COMMON.VAR'
9252 !      include 'COMMON.GEO'
9253       real(kind=8),dimension(2,2) :: pizda
9254       real(kind=8),dimension(3) :: ggg1,ggg2
9255       real(kind=8) ::  eel4,glongij,glongkl
9256       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9257 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9258 !d        eello4=0.0d0
9259 !d        return
9260 !d      endif
9261 !d      print *,'eello4:',i,j,k,l,jj,kk
9262 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
9263 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
9264 !old      eij=facont_hb(jj,i)
9265 !old      ekl=facont_hb(kk,k)
9266 !old      ekont=eij*ekl
9267       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9268 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9269       gcorr_loc(k-1)=gcorr_loc(k-1) &
9270          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9271       if (l.eq.j+1) then
9272         gcorr_loc(l-1)=gcorr_loc(l-1) &
9273            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9274       else
9275         gcorr_loc(j-1)=gcorr_loc(j-1) &
9276            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9277       endif
9278       do iii=1,2
9279         do kkk=1,5
9280           do lll=1,3
9281             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
9282                               -EAEAderx(2,2,lll,kkk,iii,1)
9283 !d            derx(lll,kkk,iii)=0.0d0
9284           enddo
9285         enddo
9286       enddo
9287 !d      gcorr_loc(l-1)=0.0d0
9288 !d      gcorr_loc(j-1)=0.0d0
9289 !d      gcorr_loc(k-1)=0.0d0
9290 !d      eel4=1.0d0
9291 !d      write (iout,*)'Contacts have occurred for peptide groups',
9292 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9293 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9294       if (j.lt.nres-1) then
9295         j1=j+1
9296         j2=j-1
9297       else
9298         j1=j-1
9299         j2=j-2
9300       endif
9301       if (l.lt.nres-1) then
9302         l1=l+1
9303         l2=l-1
9304       else
9305         l1=l-1
9306         l2=l-2
9307       endif
9308       do ll=1,3
9309 !grad        ggg1(ll)=eel4*g_contij(ll,1)
9310 !grad        ggg2(ll)=eel4*g_contij(ll,2)
9311         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9312         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9313 !grad        ghalf=0.5d0*ggg1(ll)
9314         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9315         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9316         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9317         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9318         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9319         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9320 !grad        ghalf=0.5d0*ggg2(ll)
9321         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9322         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9323         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9324         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9325         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9326         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9327       enddo
9328 !grad      do m=i+1,j-1
9329 !grad        do ll=1,3
9330 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9331 !grad        enddo
9332 !grad      enddo
9333 !grad      do m=k+1,l-1
9334 !grad        do ll=1,3
9335 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9336 !grad        enddo
9337 !grad      enddo
9338 !grad      do m=i+2,j2
9339 !grad        do ll=1,3
9340 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9341 !grad        enddo
9342 !grad      enddo
9343 !grad      do m=k+2,l2
9344 !grad        do ll=1,3
9345 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9346 !grad        enddo
9347 !grad      enddo
9348 !d      do iii=1,nres-3
9349 !d        write (2,*) iii,gcorr_loc(iii)
9350 !d      enddo
9351       eello4=ekont*eel4
9352 !d      write (2,*) 'ekont',ekont
9353 !d      write (iout,*) 'eello4',ekont*eel4
9354       return
9355       end function eello4
9356 !-----------------------------------------------------------------------------
9357       real(kind=8) function eello5(i,j,k,l,jj,kk)
9358 !      implicit real*8 (a-h,o-z)
9359 !      include 'DIMENSIONS'
9360 !      include 'COMMON.IOUNITS'
9361 !      include 'COMMON.CHAIN'
9362 !      include 'COMMON.DERIV'
9363 !      include 'COMMON.INTERACT'
9364 !      include 'COMMON.CONTACTS'
9365 !      include 'COMMON.TORSION'
9366 !      include 'COMMON.VAR'
9367 !      include 'COMMON.GEO'
9368       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9369       real(kind=8),dimension(2) :: vv
9370       real(kind=8),dimension(3) :: ggg1,ggg2
9371       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
9372       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
9373       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
9374 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9375 !                                                                              C
9376 !                            Parallel chains                                   C
9377 !                                                                              C
9378 !          o             o                   o             o                   C
9379 !         /l\           / \             \   / \           / \   /              C
9380 !        /   \         /   \             \ /   \         /   \ /               C
9381 !       j| o |l1       | o |                o| o |         | o |o                C
9382 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9383 !      \i/   \         /   \ /             /   \         /   \                 C
9384 !       o    k1             o                                                  C
9385 !         (I)          (II)                (III)          (IV)                 C
9386 !                                                                              C
9387 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9388 !                                                                              C
9389 !                            Antiparallel chains                               C
9390 !                                                                              C
9391 !          o             o                   o             o                   C
9392 !         /j\           / \             \   / \           / \   /              C
9393 !        /   \         /   \             \ /   \         /   \ /               C
9394 !      j1| o |l        | o |                o| o |         | o |o                C
9395 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9396 !      \i/   \         /   \ /             /   \         /   \                 C
9397 !       o     k1            o                                                  C
9398 !         (I)          (II)                (III)          (IV)                 C
9399 !                                                                              C
9400 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9401 !                                                                              C
9402 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
9403 !                                                                              C
9404 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9405 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9406 !d        eello5=0.0d0
9407 !d        return
9408 !d      endif
9409 !d      write (iout,*)
9410 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9411 !d     &   ' and',k,l
9412       itk=itortyp(itype(k,1))
9413       itl=itortyp(itype(l,1))
9414       itj=itortyp(itype(j,1))
9415       eello5_1=0.0d0
9416       eello5_2=0.0d0
9417       eello5_3=0.0d0
9418       eello5_4=0.0d0
9419 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9420 !d     &   eel5_3_num,eel5_4_num)
9421       do iii=1,2
9422         do kkk=1,5
9423           do lll=1,3
9424             derx(lll,kkk,iii)=0.0d0
9425           enddo
9426         enddo
9427       enddo
9428 !d      eij=facont_hb(jj,i)
9429 !d      ekl=facont_hb(kk,k)
9430 !d      ekont=eij*ekl
9431 !d      write (iout,*)'Contacts have occurred for peptide groups',
9432 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
9433 !d      goto 1111
9434 ! Contribution from the graph I.
9435 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9436 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9437       call transpose2(EUg(1,1,k),auxmat(1,1))
9438       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9439       vv(1)=pizda(1,1)-pizda(2,2)
9440       vv(2)=pizda(1,2)+pizda(2,1)
9441       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
9442        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9443 ! Explicit gradient in virtual-dihedral angles.
9444       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
9445        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
9446        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9447       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9448       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9449       vv(1)=pizda(1,1)-pizda(2,2)
9450       vv(2)=pizda(1,2)+pizda(2,1)
9451       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9452        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
9453        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9454       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9455       vv(1)=pizda(1,1)-pizda(2,2)
9456       vv(2)=pizda(1,2)+pizda(2,1)
9457       if (l.eq.j+1) then
9458         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9459          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9460          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9461       else
9462         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9463          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9464          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9465       endif
9466 ! Cartesian gradient
9467       do iii=1,2
9468         do kkk=1,5
9469           do lll=1,3
9470             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9471               pizda(1,1))
9472             vv(1)=pizda(1,1)-pizda(2,2)
9473             vv(2)=pizda(1,2)+pizda(2,1)
9474             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9475              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
9476              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9477           enddo
9478         enddo
9479       enddo
9480 !      goto 1112
9481 !1111  continue
9482 ! Contribution from graph II
9483       call transpose2(EE(1,1,itk),auxmat(1,1))
9484       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9485       vv(1)=pizda(1,1)+pizda(2,2)
9486       vv(2)=pizda(2,1)-pizda(1,2)
9487       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
9488        -0.5d0*scalar2(vv(1),Ctobr(1,k))
9489 ! Explicit gradient in virtual-dihedral angles.
9490       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9491        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9492       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9493       vv(1)=pizda(1,1)+pizda(2,2)
9494       vv(2)=pizda(2,1)-pizda(1,2)
9495       if (l.eq.j+1) then
9496         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9497          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9498          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9499       else
9500         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9501          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9502          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9503       endif
9504 ! Cartesian gradient
9505       do iii=1,2
9506         do kkk=1,5
9507           do lll=1,3
9508             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9509               pizda(1,1))
9510             vv(1)=pizda(1,1)+pizda(2,2)
9511             vv(2)=pizda(2,1)-pizda(1,2)
9512             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9513              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
9514              -0.5d0*scalar2(vv(1),Ctobr(1,k))
9515           enddo
9516         enddo
9517       enddo
9518 !d      goto 1112
9519 !d1111  continue
9520       if (l.eq.j+1) then
9521 !d        goto 1110
9522 ! Parallel orientation
9523 ! Contribution from graph III
9524         call transpose2(EUg(1,1,l),auxmat(1,1))
9525         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9526         vv(1)=pizda(1,1)-pizda(2,2)
9527         vv(2)=pizda(1,2)+pizda(2,1)
9528         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
9529          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9530 ! Explicit gradient in virtual-dihedral angles.
9531         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9532          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
9533          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9534         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9535         vv(1)=pizda(1,1)-pizda(2,2)
9536         vv(2)=pizda(1,2)+pizda(2,1)
9537         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9538          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
9539          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9540         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9541         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9542         vv(1)=pizda(1,1)-pizda(2,2)
9543         vv(2)=pizda(1,2)+pizda(2,1)
9544         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9545          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
9546          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9547 ! Cartesian gradient
9548         do iii=1,2
9549           do kkk=1,5
9550             do lll=1,3
9551               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9552                 pizda(1,1))
9553               vv(1)=pizda(1,1)-pizda(2,2)
9554               vv(2)=pizda(1,2)+pizda(2,1)
9555               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9556                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
9557                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9558             enddo
9559           enddo
9560         enddo
9561 !d        goto 1112
9562 ! Contribution from graph IV
9563 !d1110    continue
9564         call transpose2(EE(1,1,itl),auxmat(1,1))
9565         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9566         vv(1)=pizda(1,1)+pizda(2,2)
9567         vv(2)=pizda(2,1)-pizda(1,2)
9568         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
9569          -0.5d0*scalar2(vv(1),Ctobr(1,l))
9570 ! Explicit gradient in virtual-dihedral angles.
9571         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9572          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9573         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9574         vv(1)=pizda(1,1)+pizda(2,2)
9575         vv(2)=pizda(2,1)-pizda(1,2)
9576         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9577          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
9578          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9579 ! Cartesian gradient
9580         do iii=1,2
9581           do kkk=1,5
9582             do lll=1,3
9583               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9584                 pizda(1,1))
9585               vv(1)=pizda(1,1)+pizda(2,2)
9586               vv(2)=pizda(2,1)-pizda(1,2)
9587               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9588                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
9589                -0.5d0*scalar2(vv(1),Ctobr(1,l))
9590             enddo
9591           enddo
9592         enddo
9593       else
9594 ! Antiparallel orientation
9595 ! Contribution from graph III
9596 !        goto 1110
9597         call transpose2(EUg(1,1,j),auxmat(1,1))
9598         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9599         vv(1)=pizda(1,1)-pizda(2,2)
9600         vv(2)=pizda(1,2)+pizda(2,1)
9601         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
9602          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9603 ! Explicit gradient in virtual-dihedral angles.
9604         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9605          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
9606          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9607         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9608         vv(1)=pizda(1,1)-pizda(2,2)
9609         vv(2)=pizda(1,2)+pizda(2,1)
9610         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9611          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
9612          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9613         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9614         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9615         vv(1)=pizda(1,1)-pizda(2,2)
9616         vv(2)=pizda(1,2)+pizda(2,1)
9617         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9618          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
9619          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9620 ! Cartesian gradient
9621         do iii=1,2
9622           do kkk=1,5
9623             do lll=1,3
9624               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9625                 pizda(1,1))
9626               vv(1)=pizda(1,1)-pizda(2,2)
9627               vv(2)=pizda(1,2)+pizda(2,1)
9628               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9629                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
9630                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9631             enddo
9632           enddo
9633         enddo
9634 !d        goto 1112
9635 ! Contribution from graph IV
9636 1110    continue
9637         call transpose2(EE(1,1,itj),auxmat(1,1))
9638         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9639         vv(1)=pizda(1,1)+pizda(2,2)
9640         vv(2)=pizda(2,1)-pizda(1,2)
9641         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
9642          -0.5d0*scalar2(vv(1),Ctobr(1,j))
9643 ! Explicit gradient in virtual-dihedral angles.
9644         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9645          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9646         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9647         vv(1)=pizda(1,1)+pizda(2,2)
9648         vv(2)=pizda(2,1)-pizda(1,2)
9649         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9650          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
9651          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9652 ! Cartesian gradient
9653         do iii=1,2
9654           do kkk=1,5
9655             do lll=1,3
9656               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9657                 pizda(1,1))
9658               vv(1)=pizda(1,1)+pizda(2,2)
9659               vv(2)=pizda(2,1)-pizda(1,2)
9660               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9661                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
9662                -0.5d0*scalar2(vv(1),Ctobr(1,j))
9663             enddo
9664           enddo
9665         enddo
9666       endif
9667 1112  continue
9668       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9669 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9670 !d        write (2,*) 'ijkl',i,j,k,l
9671 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9672 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9673 !d      endif
9674 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9675 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9676 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9677 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9678       if (j.lt.nres-1) then
9679         j1=j+1
9680         j2=j-1
9681       else
9682         j1=j-1
9683         j2=j-2
9684       endif
9685       if (l.lt.nres-1) then
9686         l1=l+1
9687         l2=l-1
9688       else
9689         l1=l-1
9690         l2=l-2
9691       endif
9692 !d      eij=1.0d0
9693 !d      ekl=1.0d0
9694 !d      ekont=1.0d0
9695 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9696 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
9697 !        summed up outside the subrouine as for the other subroutines
9698 !        handling long-range interactions. The old code is commented out
9699 !        with "cgrad" to keep track of changes.
9700       do ll=1,3
9701 !grad        ggg1(ll)=eel5*g_contij(ll,1)
9702 !grad        ggg2(ll)=eel5*g_contij(ll,2)
9703         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9704         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9705 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9706 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9707 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9708 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9709 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9710 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9711 !     &   gradcorr5ij,
9712 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9713 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9714 !grad        ghalf=0.5d0*ggg1(ll)
9715 !d        ghalf=0.0d0
9716         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9717         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9718         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9719         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9720         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9721         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9722 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9723 !grad        ghalf=0.5d0*ggg2(ll)
9724         ghalf=0.0d0
9725         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9726         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9727         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9728         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9729         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9730         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9731       enddo
9732 !d      goto 1112
9733 !grad      do m=i+1,j-1
9734 !grad        do ll=1,3
9735 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9736 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9737 !grad        enddo
9738 !grad      enddo
9739 !grad      do m=k+1,l-1
9740 !grad        do ll=1,3
9741 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9742 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9743 !grad        enddo
9744 !grad      enddo
9745 !1112  continue
9746 !grad      do m=i+2,j2
9747 !grad        do ll=1,3
9748 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9749 !grad        enddo
9750 !grad      enddo
9751 !grad      do m=k+2,l2
9752 !grad        do ll=1,3
9753 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9754 !grad        enddo
9755 !grad      enddo
9756 !d      do iii=1,nres-3
9757 !d        write (2,*) iii,g_corr5_loc(iii)
9758 !d      enddo
9759       eello5=ekont*eel5
9760 !d      write (2,*) 'ekont',ekont
9761 !d      write (iout,*) 'eello5',ekont*eel5
9762       return
9763       end function eello5
9764 !-----------------------------------------------------------------------------
9765       real(kind=8) function eello6(i,j,k,l,jj,kk)
9766 !      implicit real*8 (a-h,o-z)
9767 !      include 'DIMENSIONS'
9768 !      include 'COMMON.IOUNITS'
9769 !      include 'COMMON.CHAIN'
9770 !      include 'COMMON.DERIV'
9771 !      include 'COMMON.INTERACT'
9772 !      include 'COMMON.CONTACTS'
9773 !      include 'COMMON.TORSION'
9774 !      include 'COMMON.VAR'
9775 !      include 'COMMON.GEO'
9776 !      include 'COMMON.FFIELD'
9777       real(kind=8),dimension(3) :: ggg1,ggg2
9778       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9779                    eello6_6,eel6
9780       real(kind=8) :: gradcorr6ij,gradcorr6kl
9781       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9782 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9783 !d        eello6=0.0d0
9784 !d        return
9785 !d      endif
9786 !d      write (iout,*)
9787 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9788 !d     &   ' and',k,l
9789       eello6_1=0.0d0
9790       eello6_2=0.0d0
9791       eello6_3=0.0d0
9792       eello6_4=0.0d0
9793       eello6_5=0.0d0
9794       eello6_6=0.0d0
9795 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9796 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9797       do iii=1,2
9798         do kkk=1,5
9799           do lll=1,3
9800             derx(lll,kkk,iii)=0.0d0
9801           enddo
9802         enddo
9803       enddo
9804 !d      eij=facont_hb(jj,i)
9805 !d      ekl=facont_hb(kk,k)
9806 !d      ekont=eij*ekl
9807 !d      eij=1.0d0
9808 !d      ekl=1.0d0
9809 !d      ekont=1.0d0
9810       if (l.eq.j+1) then
9811         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9812         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9813         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9814         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9815         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9816         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9817       else
9818         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9819         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9820         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9821         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9822         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9823           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9824         else
9825           eello6_5=0.0d0
9826         endif
9827         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9828       endif
9829 ! If turn contributions are considered, they will be handled separately.
9830       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9831 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9832 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9833 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9834 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9835 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9836 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9837 !d      goto 1112
9838       if (j.lt.nres-1) then
9839         j1=j+1
9840         j2=j-1
9841       else
9842         j1=j-1
9843         j2=j-2
9844       endif
9845       if (l.lt.nres-1) then
9846         l1=l+1
9847         l2=l-1
9848       else
9849         l1=l-1
9850         l2=l-2
9851       endif
9852       do ll=1,3
9853 !grad        ggg1(ll)=eel6*g_contij(ll,1)
9854 !grad        ggg2(ll)=eel6*g_contij(ll,2)
9855 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9856 !grad        ghalf=0.5d0*ggg1(ll)
9857 !d        ghalf=0.0d0
9858         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9859         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9860         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9861         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9862         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9863         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9864         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9865         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9866 !grad        ghalf=0.5d0*ggg2(ll)
9867 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9868 !d        ghalf=0.0d0
9869         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9870         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9871         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9872         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9873         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9874         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9875       enddo
9876 !d      goto 1112
9877 !grad      do m=i+1,j-1
9878 !grad        do ll=1,3
9879 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9880 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9881 !grad        enddo
9882 !grad      enddo
9883 !grad      do m=k+1,l-1
9884 !grad        do ll=1,3
9885 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9886 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9887 !grad        enddo
9888 !grad      enddo
9889 !grad1112  continue
9890 !grad      do m=i+2,j2
9891 !grad        do ll=1,3
9892 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9893 !grad        enddo
9894 !grad      enddo
9895 !grad      do m=k+2,l2
9896 !grad        do ll=1,3
9897 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9898 !grad        enddo
9899 !grad      enddo
9900 !d      do iii=1,nres-3
9901 !d        write (2,*) iii,g_corr6_loc(iii)
9902 !d      enddo
9903       eello6=ekont*eel6
9904 !d      write (2,*) 'ekont',ekont
9905 !d      write (iout,*) 'eello6',ekont*eel6
9906       return
9907       end function eello6
9908 !-----------------------------------------------------------------------------
9909       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
9910       use comm_kut
9911 !      implicit real*8 (a-h,o-z)
9912 !      include 'DIMENSIONS'
9913 !      include 'COMMON.IOUNITS'
9914 !      include 'COMMON.CHAIN'
9915 !      include 'COMMON.DERIV'
9916 !      include 'COMMON.INTERACT'
9917 !      include 'COMMON.CONTACTS'
9918 !      include 'COMMON.TORSION'
9919 !      include 'COMMON.VAR'
9920 !      include 'COMMON.GEO'
9921       real(kind=8),dimension(2) :: vv,vv1
9922       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
9923       logical :: swap
9924 !el      logical :: lprn
9925 !el      common /kutas/ lprn
9926       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
9927       real(kind=8) :: s1,s2,s3,s4,s5
9928 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9929 !                                                                              C
9930 !      Parallel       Antiparallel                                             C
9931 !                                                                              C
9932 !          o             o                                                     C
9933 !         /l\           /j\                                                    C
9934 !        /   \         /   \                                                   C
9935 !       /| o |         | o |\                                                  C
9936 !     \ j|/k\|  /   \  |/k\|l /                                                C
9937 !      \ /   \ /     \ /   \ /                                                 C
9938 !       o     o       o     o                                                  C
9939 !       i             i                                                        C
9940 !                                                                              C
9941 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9942       itk=itortyp(itype(k,1))
9943       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9944       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9945       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9946       call transpose2(EUgC(1,1,k),auxmat(1,1))
9947       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9948       vv1(1)=pizda1(1,1)-pizda1(2,2)
9949       vv1(2)=pizda1(1,2)+pizda1(2,1)
9950       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9951       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
9952       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
9953       s5=scalar2(vv(1),Dtobr2(1,i))
9954 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9955       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9956       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
9957        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
9958        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
9959        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
9960        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
9961        +scalar2(vv(1),Dtobr2der(1,i)))
9962       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9963       vv1(1)=pizda1(1,1)-pizda1(2,2)
9964       vv1(2)=pizda1(1,2)+pizda1(2,1)
9965       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
9966       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
9967       if (l.eq.j+1) then
9968         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
9969        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9970        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9971        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9972        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9973       else
9974         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
9975        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9976        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9977        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9978        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9979       endif
9980       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9981       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9982       vv1(1)=pizda1(1,1)-pizda1(2,2)
9983       vv1(2)=pizda1(1,2)+pizda1(2,1)
9984       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
9985        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
9986        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
9987        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9988       do iii=1,2
9989         if (swap) then
9990           ind=3-iii
9991         else
9992           ind=iii
9993         endif
9994         do kkk=1,5
9995           do lll=1,3
9996             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9997             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9998             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9999             call transpose2(EUgC(1,1,k),auxmat(1,1))
10000             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10001               pizda1(1,1))
10002             vv1(1)=pizda1(1,1)-pizda1(2,2)
10003             vv1(2)=pizda1(1,2)+pizda1(2,1)
10004             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10005             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
10006              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
10007             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
10008              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
10009             s5=scalar2(vv(1),Dtobr2(1,i))
10010             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10011           enddo
10012         enddo
10013       enddo
10014       return
10015       end function eello6_graph1
10016 !-----------------------------------------------------------------------------
10017       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
10018       use comm_kut
10019 !      implicit real*8 (a-h,o-z)
10020 !      include 'DIMENSIONS'
10021 !      include 'COMMON.IOUNITS'
10022 !      include 'COMMON.CHAIN'
10023 !      include 'COMMON.DERIV'
10024 !      include 'COMMON.INTERACT'
10025 !      include 'COMMON.CONTACTS'
10026 !      include 'COMMON.TORSION'
10027 !      include 'COMMON.VAR'
10028 !      include 'COMMON.GEO'
10029       logical :: swap
10030       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
10031       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10032 !el      logical :: lprn
10033 !el      common /kutas/ lprn
10034       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
10035       real(kind=8) :: s2,s3,s4
10036 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10037 !                                                                              C
10038 !      Parallel       Antiparallel                                             C
10039 !                                                                              C
10040 !          o             o                                                     C
10041 !     \   /l\           /j\   /                                                C
10042 !      \ /   \         /   \ /                                                 C
10043 !       o| o |         | o |o                                                  C
10044 !     \ j|/k\|      \  |/k\|l                                                  C
10045 !      \ /   \       \ /   \                                                   C
10046 !       o             o                                                        C
10047 !       i             i                                                        C
10048 !                                                                              C
10049 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10050 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10051 ! AL 7/4/01 s1 would occur in the sixth-order moment,
10052 !           but not in a cluster cumulant
10053 #ifdef MOMENT
10054       s1=dip(1,jj,i)*dip(1,kk,k)
10055 #endif
10056       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10057       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10058       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10059       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10060       call transpose2(EUg(1,1,k),auxmat(1,1))
10061       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10062       vv(1)=pizda(1,1)-pizda(2,2)
10063       vv(2)=pizda(1,2)+pizda(2,1)
10064       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10065 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10066 #ifdef MOMENT
10067       eello6_graph2=-(s1+s2+s3+s4)
10068 #else
10069       eello6_graph2=-(s2+s3+s4)
10070 #endif
10071 !      eello6_graph2=-s3
10072 ! Derivatives in gamma(i-1)
10073       if (i.gt.1) then
10074 #ifdef MOMENT
10075         s1=dipderg(1,jj,i)*dip(1,kk,k)
10076 #endif
10077         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10078         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10079         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10080         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10081 #ifdef MOMENT
10082         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10083 #else
10084         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10085 #endif
10086 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10087       endif
10088 ! Derivatives in gamma(k-1)
10089 #ifdef MOMENT
10090       s1=dip(1,jj,i)*dipderg(1,kk,k)
10091 #endif
10092       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10093       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10094       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10095       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10096       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10097       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10098       vv(1)=pizda(1,1)-pizda(2,2)
10099       vv(2)=pizda(1,2)+pizda(2,1)
10100       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10101 #ifdef MOMENT
10102       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10103 #else
10104       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10105 #endif
10106 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10107 ! Derivatives in gamma(j-1) or gamma(l-1)
10108       if (j.gt.1) then
10109 #ifdef MOMENT
10110         s1=dipderg(3,jj,i)*dip(1,kk,k)
10111 #endif
10112         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10113         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10114         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10115         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10116         vv(1)=pizda(1,1)-pizda(2,2)
10117         vv(2)=pizda(1,2)+pizda(2,1)
10118         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10119 #ifdef MOMENT
10120         if (swap) then
10121           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10122         else
10123           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10124         endif
10125 #endif
10126         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10127 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10128       endif
10129 ! Derivatives in gamma(l-1) or gamma(j-1)
10130       if (l.gt.1) then
10131 #ifdef MOMENT
10132         s1=dip(1,jj,i)*dipderg(3,kk,k)
10133 #endif
10134         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10135         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10136         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10137         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10138         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10139         vv(1)=pizda(1,1)-pizda(2,2)
10140         vv(2)=pizda(1,2)+pizda(2,1)
10141         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10142 #ifdef MOMENT
10143         if (swap) then
10144           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10145         else
10146           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10147         endif
10148 #endif
10149         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10150 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10151       endif
10152 ! Cartesian derivatives.
10153       if (lprn) then
10154         write (2,*) 'In eello6_graph2'
10155         do iii=1,2
10156           write (2,*) 'iii=',iii
10157           do kkk=1,5
10158             write (2,*) 'kkk=',kkk
10159             do jjj=1,2
10160               write (2,'(3(2f10.5),5x)') &
10161               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10162             enddo
10163           enddo
10164         enddo
10165       endif
10166       do iii=1,2
10167         do kkk=1,5
10168           do lll=1,3
10169 #ifdef MOMENT
10170             if (iii.eq.1) then
10171               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10172             else
10173               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10174             endif
10175 #endif
10176             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
10177               auxvec(1))
10178             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10179             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
10180               auxvec(1))
10181             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10182             call transpose2(EUg(1,1,k),auxmat(1,1))
10183             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
10184               pizda(1,1))
10185             vv(1)=pizda(1,1)-pizda(2,2)
10186             vv(2)=pizda(1,2)+pizda(2,1)
10187             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10188 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10189 #ifdef MOMENT
10190             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10191 #else
10192             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10193 #endif
10194             if (swap) then
10195               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10196             else
10197               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10198             endif
10199           enddo
10200         enddo
10201       enddo
10202       return
10203       end function eello6_graph2
10204 !-----------------------------------------------------------------------------
10205       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
10206 !      implicit real*8 (a-h,o-z)
10207 !      include 'DIMENSIONS'
10208 !      include 'COMMON.IOUNITS'
10209 !      include 'COMMON.CHAIN'
10210 !      include 'COMMON.DERIV'
10211 !      include 'COMMON.INTERACT'
10212 !      include 'COMMON.CONTACTS'
10213 !      include 'COMMON.TORSION'
10214 !      include 'COMMON.VAR'
10215 !      include 'COMMON.GEO'
10216       real(kind=8),dimension(2) :: vv,auxvec
10217       real(kind=8),dimension(2,2) :: pizda,auxmat
10218       logical :: swap
10219       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
10220       real(kind=8) :: s1,s2,s3,s4
10221 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10222 !                                                                              C
10223 !      Parallel       Antiparallel                                             C
10224 !                                                                              C
10225 !          o             o                                                     C
10226 !         /l\   /   \   /j\                                                    C
10227 !        /   \ /     \ /   \                                                   C
10228 !       /| o |o       o| o |\                                                  C
10229 !       j|/k\|  /      |/k\|l /                                                C
10230 !        /   \ /       /   \ /                                                 C
10231 !       /     o       /     o                                                  C
10232 !       i             i                                                        C
10233 !                                                                              C
10234 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10235 !
10236 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10237 !           energy moment and not to the cluster cumulant.
10238       iti=itortyp(itype(i,1))
10239       if (j.lt.nres-1) then
10240         itj1=itortyp(itype(j+1,1))
10241       else
10242         itj1=ntortyp+1
10243       endif
10244       itk=itortyp(itype(k,1))
10245       itk1=itortyp(itype(k+1,1))
10246       if (l.lt.nres-1) then
10247         itl1=itortyp(itype(l+1,1))
10248       else
10249         itl1=ntortyp+1
10250       endif
10251 #ifdef MOMENT
10252       s1=dip(4,jj,i)*dip(4,kk,k)
10253 #endif
10254       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
10255       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10256       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
10257       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10258       call transpose2(EE(1,1,itk),auxmat(1,1))
10259       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10260       vv(1)=pizda(1,1)+pizda(2,2)
10261       vv(2)=pizda(2,1)-pizda(1,2)
10262       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10263 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10264 !d     & "sum",-(s2+s3+s4)
10265 #ifdef MOMENT
10266       eello6_graph3=-(s1+s2+s3+s4)
10267 #else
10268       eello6_graph3=-(s2+s3+s4)
10269 #endif
10270 !      eello6_graph3=-s4
10271 ! Derivatives in gamma(k-1)
10272       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
10273       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10274       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10275       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10276 ! Derivatives in gamma(l-1)
10277       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
10278       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10279       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10280       vv(1)=pizda(1,1)+pizda(2,2)
10281       vv(2)=pizda(2,1)-pizda(1,2)
10282       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10283       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10284 ! Cartesian derivatives.
10285       do iii=1,2
10286         do kkk=1,5
10287           do lll=1,3
10288 #ifdef MOMENT
10289             if (iii.eq.1) then
10290               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10291             else
10292               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10293             endif
10294 #endif
10295             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
10296               auxvec(1))
10297             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10298             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
10299               auxvec(1))
10300             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10301             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
10302               pizda(1,1))
10303             vv(1)=pizda(1,1)+pizda(2,2)
10304             vv(2)=pizda(2,1)-pizda(1,2)
10305             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10306 #ifdef MOMENT
10307             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10308 #else
10309             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10310 #endif
10311             if (swap) then
10312               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10313             else
10314               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10315             endif
10316 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10317           enddo
10318         enddo
10319       enddo
10320       return
10321       end function eello6_graph3
10322 !-----------------------------------------------------------------------------
10323       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10324 !      implicit real*8 (a-h,o-z)
10325 !      include 'DIMENSIONS'
10326 !      include 'COMMON.IOUNITS'
10327 !      include 'COMMON.CHAIN'
10328 !      include 'COMMON.DERIV'
10329 !      include 'COMMON.INTERACT'
10330 !      include 'COMMON.CONTACTS'
10331 !      include 'COMMON.TORSION'
10332 !      include 'COMMON.VAR'
10333 !      include 'COMMON.GEO'
10334 !      include 'COMMON.FFIELD'
10335       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
10336       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10337       logical :: swap
10338       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
10339               iii,kkk,lll
10340       real(kind=8) :: s1,s2,s3,s4
10341 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10342 !                                                                              C
10343 !      Parallel       Antiparallel                                             C
10344 !                                                                              C
10345 !          o             o                                                     C
10346 !         /l\   /   \   /j\                                                    C
10347 !        /   \ /     \ /   \                                                   C
10348 !       /| o |o       o| o |\                                                  C
10349 !     \ j|/k\|      \  |/k\|l                                                  C
10350 !      \ /   \       \ /   \                                                   C
10351 !       o     \       o     \                                                  C
10352 !       i             i                                                        C
10353 !                                                                              C
10354 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10355 !
10356 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10357 !           energy moment and not to the cluster cumulant.
10358 !d      write (2,*) 'eello_graph4: wturn6',wturn6
10359       iti=itortyp(itype(i,1))
10360       itj=itortyp(itype(j,1))
10361       if (j.lt.nres-1) then
10362         itj1=itortyp(itype(j+1,1))
10363       else
10364         itj1=ntortyp+1
10365       endif
10366       itk=itortyp(itype(k,1))
10367       if (k.lt.nres-1) then
10368         itk1=itortyp(itype(k+1,1))
10369       else
10370         itk1=ntortyp+1
10371       endif
10372       itl=itortyp(itype(l,1))
10373       if (l.lt.nres-1) then
10374         itl1=itortyp(itype(l+1,1))
10375       else
10376         itl1=ntortyp+1
10377       endif
10378 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10379 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10380 !d     & ' itl',itl,' itl1',itl1
10381 #ifdef MOMENT
10382       if (imat.eq.1) then
10383         s1=dip(3,jj,i)*dip(3,kk,k)
10384       else
10385         s1=dip(2,jj,j)*dip(2,kk,l)
10386       endif
10387 #endif
10388       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10389       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10390       if (j.eq.l+1) then
10391         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
10392         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10393       else
10394         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
10395         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10396       endif
10397       call transpose2(EUg(1,1,k),auxmat(1,1))
10398       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10399       vv(1)=pizda(1,1)-pizda(2,2)
10400       vv(2)=pizda(2,1)+pizda(1,2)
10401       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10402 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10403 #ifdef MOMENT
10404       eello6_graph4=-(s1+s2+s3+s4)
10405 #else
10406       eello6_graph4=-(s2+s3+s4)
10407 #endif
10408 ! Derivatives in gamma(i-1)
10409       if (i.gt.1) then
10410 #ifdef MOMENT
10411         if (imat.eq.1) then
10412           s1=dipderg(2,jj,i)*dip(3,kk,k)
10413         else
10414           s1=dipderg(4,jj,j)*dip(2,kk,l)
10415         endif
10416 #endif
10417         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10418         if (j.eq.l+1) then
10419           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
10420           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10421         else
10422           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
10423           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10424         endif
10425         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10426         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10427 !d          write (2,*) 'turn6 derivatives'
10428 #ifdef MOMENT
10429           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10430 #else
10431           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10432 #endif
10433         else
10434 #ifdef MOMENT
10435           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10436 #else
10437           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10438 #endif
10439         endif
10440       endif
10441 ! Derivatives in gamma(k-1)
10442 #ifdef MOMENT
10443       if (imat.eq.1) then
10444         s1=dip(3,jj,i)*dipderg(2,kk,k)
10445       else
10446         s1=dip(2,jj,j)*dipderg(4,kk,l)
10447       endif
10448 #endif
10449       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10450       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10451       if (j.eq.l+1) then
10452         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
10453         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10454       else
10455         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
10456         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10457       endif
10458       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10459       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10460       vv(1)=pizda(1,1)-pizda(2,2)
10461       vv(2)=pizda(2,1)+pizda(1,2)
10462       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10463       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10464 #ifdef MOMENT
10465         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10466 #else
10467         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10468 #endif
10469       else
10470 #ifdef MOMENT
10471         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10472 #else
10473         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10474 #endif
10475       endif
10476 ! Derivatives in gamma(j-1) or gamma(l-1)
10477       if (l.eq.j+1 .and. l.gt.1) then
10478         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10479         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10480         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10481         vv(1)=pizda(1,1)-pizda(2,2)
10482         vv(2)=pizda(2,1)+pizda(1,2)
10483         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10484         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10485       else if (j.gt.1) then
10486         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10487         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10488         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10489         vv(1)=pizda(1,1)-pizda(2,2)
10490         vv(2)=pizda(2,1)+pizda(1,2)
10491         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10492         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10493           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10494         else
10495           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10496         endif
10497       endif
10498 ! Cartesian derivatives.
10499       do iii=1,2
10500         do kkk=1,5
10501           do lll=1,3
10502 #ifdef MOMENT
10503             if (iii.eq.1) then
10504               if (imat.eq.1) then
10505                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10506               else
10507                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10508               endif
10509             else
10510               if (imat.eq.1) then
10511                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10512               else
10513                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10514               endif
10515             endif
10516 #endif
10517             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
10518               auxvec(1))
10519             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10520             if (j.eq.l+1) then
10521               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10522                 b1(1,itj1),auxvec(1))
10523               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
10524             else
10525               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10526                 b1(1,itl1),auxvec(1))
10527               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
10528             endif
10529             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10530               pizda(1,1))
10531             vv(1)=pizda(1,1)-pizda(2,2)
10532             vv(2)=pizda(2,1)+pizda(1,2)
10533             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10534             if (swap) then
10535               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10536 #ifdef MOMENT
10537                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10538                    -(s1+s2+s4)
10539 #else
10540                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10541                    -(s2+s4)
10542 #endif
10543                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10544               else
10545 #ifdef MOMENT
10546                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10547 #else
10548                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10549 #endif
10550                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10551               endif
10552             else
10553 #ifdef MOMENT
10554               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10555 #else
10556               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10557 #endif
10558               if (l.eq.j+1) then
10559                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10560               else
10561                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10562               endif
10563             endif
10564           enddo
10565         enddo
10566       enddo
10567       return
10568       end function eello6_graph4
10569 !-----------------------------------------------------------------------------
10570       real(kind=8) function eello_turn6(i,jj,kk)
10571 !      implicit real*8 (a-h,o-z)
10572 !      include 'DIMENSIONS'
10573 !      include 'COMMON.IOUNITS'
10574 !      include 'COMMON.CHAIN'
10575 !      include 'COMMON.DERIV'
10576 !      include 'COMMON.INTERACT'
10577 !      include 'COMMON.CONTACTS'
10578 !      include 'COMMON.TORSION'
10579 !      include 'COMMON.VAR'
10580 !      include 'COMMON.GEO'
10581       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
10582       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
10583       real(kind=8),dimension(3) :: ggg1,ggg2
10584       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
10585       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
10586 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10587 !           the respective energy moment and not to the cluster cumulant.
10588 !el local variables
10589       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
10590       integer :: j1,j2,l1,l2,ll
10591       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
10592       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
10593       s1=0.0d0
10594       s8=0.0d0
10595       s13=0.0d0
10596 !
10597       eello_turn6=0.0d0
10598       j=i+4
10599       k=i+1
10600       l=i+3
10601       iti=itortyp(itype(i,1))
10602       itk=itortyp(itype(k,1))
10603       itk1=itortyp(itype(k+1,1))
10604       itl=itortyp(itype(l,1))
10605       itj=itortyp(itype(j,1))
10606 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10607 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
10608 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10609 !d        eello6=0.0d0
10610 !d        return
10611 !d      endif
10612 !d      write (iout,*)
10613 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10614 !d     &   ' and',k,l
10615 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
10616       do iii=1,2
10617         do kkk=1,5
10618           do lll=1,3
10619             derx_turn(lll,kkk,iii)=0.0d0
10620           enddo
10621         enddo
10622       enddo
10623 !d      eij=1.0d0
10624 !d      ekl=1.0d0
10625 !d      ekont=1.0d0
10626       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10627 !d      eello6_5=0.0d0
10628 !d      write (2,*) 'eello6_5',eello6_5
10629 #ifdef MOMENT
10630       call transpose2(AEA(1,1,1),auxmat(1,1))
10631       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10632       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
10633       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10634 #endif
10635       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10636       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10637       s2 = scalar2(b1(1,itk),vtemp1(1))
10638 #ifdef MOMENT
10639       call transpose2(AEA(1,1,2),atemp(1,1))
10640       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10641       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10642       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10643 #endif
10644       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10645       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10646       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10647 #ifdef MOMENT
10648       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10649       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10650       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10651       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10652       ss13 = scalar2(b1(1,itk),vtemp4(1))
10653       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10654 #endif
10655 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10656 !      s1=0.0d0
10657 !      s2=0.0d0
10658 !      s8=0.0d0
10659 !      s12=0.0d0
10660 !      s13=0.0d0
10661       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10662 ! Derivatives in gamma(i+2)
10663       s1d =0.0d0
10664       s8d =0.0d0
10665 #ifdef MOMENT
10666       call transpose2(AEA(1,1,1),auxmatd(1,1))
10667       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10668       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10669       call transpose2(AEAderg(1,1,2),atempd(1,1))
10670       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10671       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10672 #endif
10673       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10674       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10675       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10676 !      s1d=0.0d0
10677 !      s2d=0.0d0
10678 !      s8d=0.0d0
10679 !      s12d=0.0d0
10680 !      s13d=0.0d0
10681       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10682 ! Derivatives in gamma(i+3)
10683 #ifdef MOMENT
10684       call transpose2(AEA(1,1,1),auxmatd(1,1))
10685       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10686       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
10687       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10688 #endif
10689       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
10690       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10691       s2d = scalar2(b1(1,itk),vtemp1d(1))
10692 #ifdef MOMENT
10693       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10694       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10695 #endif
10696       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10697 #ifdef MOMENT
10698       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10699       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10700       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10701 #endif
10702 !      s1d=0.0d0
10703 !      s2d=0.0d0
10704 !      s8d=0.0d0
10705 !      s12d=0.0d0
10706 !      s13d=0.0d0
10707 #ifdef MOMENT
10708       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10709                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10710 #else
10711       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10712                     -0.5d0*ekont*(s2d+s12d)
10713 #endif
10714 ! Derivatives in gamma(i+4)
10715       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10716       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10717       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10718 #ifdef MOMENT
10719       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10720       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10721       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10722 #endif
10723 !      s1d=0.0d0
10724 !      s2d=0.0d0
10725 !      s8d=0.0d0
10726 !      s12d=0.0d0
10727 !      s13d=0.0d0
10728 #ifdef MOMENT
10729       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10730 #else
10731       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10732 #endif
10733 ! Derivatives in gamma(i+5)
10734 #ifdef MOMENT
10735       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10736       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10737       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10738 #endif
10739       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10740       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10741       s2d = scalar2(b1(1,itk),vtemp1d(1))
10742 #ifdef MOMENT
10743       call transpose2(AEA(1,1,2),atempd(1,1))
10744       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10745       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10746 #endif
10747       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10748       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10749 #ifdef MOMENT
10750       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10751       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10752       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10753 #endif
10754 !      s1d=0.0d0
10755 !      s2d=0.0d0
10756 !      s8d=0.0d0
10757 !      s12d=0.0d0
10758 !      s13d=0.0d0
10759 #ifdef MOMENT
10760       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10761                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10762 #else
10763       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10764                     -0.5d0*ekont*(s2d+s12d)
10765 #endif
10766 ! Cartesian derivatives
10767       do iii=1,2
10768         do kkk=1,5
10769           do lll=1,3
10770 #ifdef MOMENT
10771             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10772             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10773             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10774 #endif
10775             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10776             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10777                 vtemp1d(1))
10778             s2d = scalar2(b1(1,itk),vtemp1d(1))
10779 #ifdef MOMENT
10780             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10781             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10782             s8d = -(atempd(1,1)+atempd(2,2))* &
10783                  scalar2(cc(1,1,itl),vtemp2(1))
10784 #endif
10785             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10786                  auxmatd(1,1))
10787             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10788             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10789 !      s1d=0.0d0
10790 !      s2d=0.0d0
10791 !      s8d=0.0d0
10792 !      s12d=0.0d0
10793 !      s13d=0.0d0
10794 #ifdef MOMENT
10795             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10796               - 0.5d0*(s1d+s2d)
10797 #else
10798             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10799               - 0.5d0*s2d
10800 #endif
10801 #ifdef MOMENT
10802             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10803               - 0.5d0*(s8d+s12d)
10804 #else
10805             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10806               - 0.5d0*s12d
10807 #endif
10808           enddo
10809         enddo
10810       enddo
10811 #ifdef MOMENT
10812       do kkk=1,5
10813         do lll=1,3
10814           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10815             achuj_tempd(1,1))
10816           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10817           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10818           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10819           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10820           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10821             vtemp4d(1))
10822           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10823           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10824           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10825         enddo
10826       enddo
10827 #endif
10828 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10829 !d     &  16*eel_turn6_num
10830 !d      goto 1112
10831       if (j.lt.nres-1) then
10832         j1=j+1
10833         j2=j-1
10834       else
10835         j1=j-1
10836         j2=j-2
10837       endif
10838       if (l.lt.nres-1) then
10839         l1=l+1
10840         l2=l-1
10841       else
10842         l1=l-1
10843         l2=l-2
10844       endif
10845       do ll=1,3
10846 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10847 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10848 !grad        ghalf=0.5d0*ggg1(ll)
10849 !d        ghalf=0.0d0
10850         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10851         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10852         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
10853           +ekont*derx_turn(ll,2,1)
10854         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10855         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
10856           +ekont*derx_turn(ll,4,1)
10857         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10858         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10859         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10860 !grad        ghalf=0.5d0*ggg2(ll)
10861 !d        ghalf=0.0d0
10862         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
10863           +ekont*derx_turn(ll,2,2)
10864         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10865         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10866           +ekont*derx_turn(ll,4,2)
10867         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10868         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10869         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10870       enddo
10871 !d      goto 1112
10872 !grad      do m=i+1,j-1
10873 !grad        do ll=1,3
10874 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10875 !grad        enddo
10876 !grad      enddo
10877 !grad      do m=k+1,l-1
10878 !grad        do ll=1,3
10879 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10880 !grad        enddo
10881 !grad      enddo
10882 !grad1112  continue
10883 !grad      do m=i+2,j2
10884 !grad        do ll=1,3
10885 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10886 !grad        enddo
10887 !grad      enddo
10888 !grad      do m=k+2,l2
10889 !grad        do ll=1,3
10890 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10891 !grad        enddo
10892 !grad      enddo
10893 !d      do iii=1,nres-3
10894 !d        write (2,*) iii,g_corr6_loc(iii)
10895 !d      enddo
10896       eello_turn6=ekont*eel_turn6
10897 !d      write (2,*) 'ekont',ekont
10898 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
10899       return
10900       end function eello_turn6
10901 !-----------------------------------------------------------------------------
10902       subroutine MATVEC2(A1,V1,V2)
10903 !DIR$ INLINEALWAYS MATVEC2
10904 #ifndef OSF
10905 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10906 #endif
10907 !      implicit real*8 (a-h,o-z)
10908 !      include 'DIMENSIONS'
10909       real(kind=8),dimension(2) :: V1,V2
10910       real(kind=8),dimension(2,2) :: A1
10911       real(kind=8) :: vaux1,vaux2
10912 !      DO 1 I=1,2
10913 !        VI=0.0
10914 !        DO 3 K=1,2
10915 !    3     VI=VI+A1(I,K)*V1(K)
10916 !        Vaux(I)=VI
10917 !    1 CONTINUE
10918
10919       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10920       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10921
10922       v2(1)=vaux1
10923       v2(2)=vaux2
10924       end subroutine MATVEC2
10925 !-----------------------------------------------------------------------------
10926       subroutine MATMAT2(A1,A2,A3)
10927 #ifndef OSF
10928 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10929 #endif
10930 !      implicit real*8 (a-h,o-z)
10931 !      include 'DIMENSIONS'
10932       real(kind=8),dimension(2,2) :: A1,A2,A3
10933       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
10934 !      DIMENSION AI3(2,2)
10935 !        DO  J=1,2
10936 !          A3IJ=0.0
10937 !          DO K=1,2
10938 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10939 !          enddo
10940 !          A3(I,J)=A3IJ
10941 !       enddo
10942 !      enddo
10943
10944       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10945       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10946       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10947       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10948
10949       A3(1,1)=AI3_11
10950       A3(2,1)=AI3_21
10951       A3(1,2)=AI3_12
10952       A3(2,2)=AI3_22
10953       end subroutine MATMAT2
10954 !-----------------------------------------------------------------------------
10955       real(kind=8) function scalar2(u,v)
10956 !DIR$ INLINEALWAYS scalar2
10957       implicit none
10958       real(kind=8),dimension(2) :: u,v
10959       real(kind=8) :: sc
10960       integer :: i
10961       scalar2=u(1)*v(1)+u(2)*v(2)
10962       return
10963       end function scalar2
10964 !-----------------------------------------------------------------------------
10965       subroutine transpose2(a,at)
10966 !DIR$ INLINEALWAYS transpose2
10967 #ifndef OSF
10968 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
10969 #endif
10970       implicit none
10971       real(kind=8),dimension(2,2) :: a,at
10972       at(1,1)=a(1,1)
10973       at(1,2)=a(2,1)
10974       at(2,1)=a(1,2)
10975       at(2,2)=a(2,2)
10976       return
10977       end subroutine transpose2
10978 !-----------------------------------------------------------------------------
10979       subroutine transpose(n,a,at)
10980       implicit none
10981       integer :: n,i,j
10982       real(kind=8),dimension(n,n) :: a,at
10983       do i=1,n
10984         do j=1,n
10985           at(j,i)=a(i,j)
10986         enddo
10987       enddo
10988       return
10989       end subroutine transpose
10990 !-----------------------------------------------------------------------------
10991       subroutine prodmat3(a1,a2,kk,transp,prod)
10992 !DIR$ INLINEALWAYS prodmat3
10993 #ifndef OSF
10994 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
10995 #endif
10996       implicit none
10997       integer :: i,j
10998       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
10999       logical :: transp
11000 !rc      double precision auxmat(2,2),prod_(2,2)
11001
11002       if (transp) then
11003 !rc        call transpose2(kk(1,1),auxmat(1,1))
11004 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11005 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11006
11007            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
11008        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11009            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
11010        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11011            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
11012        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11013            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
11014        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11015
11016       else
11017 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11018 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11019
11020            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
11021         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11022            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
11023         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11024            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
11025         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11026            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
11027         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11028
11029       endif
11030 !      call transpose2(a2(1,1),a2t(1,1))
11031
11032 !rc      print *,transp
11033 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
11034 !rc      print *,((prod(i,j),i=1,2),j=1,2)
11035
11036       return
11037       end subroutine prodmat3
11038 !-----------------------------------------------------------------------------
11039 ! energy_p_new_barrier.F
11040 !-----------------------------------------------------------------------------
11041       subroutine sum_gradient
11042 !      implicit real*8 (a-h,o-z)
11043       use io_base, only: pdbout
11044 !      include 'DIMENSIONS'
11045 #ifndef ISNAN
11046       external proc_proc
11047 #ifdef WINPGI
11048 !MS$ATTRIBUTES C ::  proc_proc
11049 #endif
11050 #endif
11051 #ifdef MPI
11052       include 'mpif.h'
11053 #endif
11054       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
11055                    gloc_scbuf !(3,maxres)
11056
11057       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
11058 !#endif
11059 !el local variables
11060       integer :: i,j,k,ierror,ierr
11061       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
11062                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
11063                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
11064                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
11065                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
11066                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
11067                    gsccorr_max,gsccorrx_max,time00
11068
11069 !      include 'COMMON.SETUP'
11070 !      include 'COMMON.IOUNITS'
11071 !      include 'COMMON.FFIELD'
11072 !      include 'COMMON.DERIV'
11073 !      include 'COMMON.INTERACT'
11074 !      include 'COMMON.SBRIDGE'
11075 !      include 'COMMON.CHAIN'
11076 !      include 'COMMON.VAR'
11077 !      include 'COMMON.CONTROL'
11078 !      include 'COMMON.TIME1'
11079 !      include 'COMMON.MAXGRAD'
11080 !      include 'COMMON.SCCOR'
11081 #ifdef TIMING
11082       time01=MPI_Wtime()
11083 #endif
11084 !#define DEBUG
11085 #ifdef DEBUG
11086       write (iout,*) "sum_gradient gvdwc, gvdwx"
11087       do i=1,nres
11088         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11089          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
11090       enddo
11091       call flush(iout)
11092 #endif
11093 #ifdef MPI
11094         gradbufc=0.0d0
11095         gradbufx=0.0d0
11096         gradbufc_sum=0.0d0
11097         gloc_scbuf=0.0d0
11098         glocbuf=0.0d0
11099 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
11100         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
11101           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
11102 #endif
11103 !
11104 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
11105 !            in virtual-bond-vector coordinates
11106 !
11107 #ifdef DEBUG
11108 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
11109 !      do i=1,nres-1
11110 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
11111 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
11112 !      enddo
11113 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
11114 !      do i=1,nres-1
11115 !        write (iout,'(i5,3f10.5,2x,f10.5)')
11116 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
11117 !      enddo
11118 !      write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
11119 !      do i=1,nres
11120 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11121 !         i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
11122 !         (gvdwc_scpp(j,i),j=1,3)
11123 !      enddo
11124 !      write (iout,*) "gelc_long gvdwpp gel_loc_long"
11125 !      do i=1,nres
11126 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11127 !         i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
11128 !         (gelc_loc_long(j,i),j=1,3)
11129 !      enddo
11130       call flush(iout)
11131 #endif
11132 #ifdef SPLITELE
11133       do i=0,nct
11134         do j=1,3
11135           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11136                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11137                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11138                       wel_loc*gel_loc_long(j,i)+ &
11139                       wcorr*gradcorr_long(j,i)+ &
11140                       wcorr5*gradcorr5_long(j,i)+ &
11141                       wcorr6*gradcorr6_long(j,i)+ &
11142                       wturn6*gcorr6_turn_long(j,i)+ &
11143                       wstrain*ghpbc(j,i) &
11144                      +wliptran*gliptranc(j,i) &
11145                      +gradafm(j,i) &
11146                      +welec*gshieldc(j,i) &
11147                      +wcorr*gshieldc_ec(j,i) &
11148                      +wturn3*gshieldc_t3(j,i)&
11149                      +wturn4*gshieldc_t4(j,i)&
11150                      +wel_loc*gshieldc_ll(j,i)&
11151                      +wtube*gg_tube(j,i) &
11152                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11153                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11154                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11155                      wcorr_nucl*gradcorr_nucl(j,i)&
11156                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
11157                      wcatprot* gradpepcat(j,i)+ &
11158                      wcatcat*gradcatcat(j,i)+   &
11159                      wscbase*gvdwc_scbase(j,i)+ &
11160                      wpepbase*gvdwc_pepbase(j,i)+&
11161                      wscpho*gvdwc_scpho(j,i)+   &
11162                      wpeppho*gvdwc_peppho(j,i)+wcatnucl*gradnuclcat(j,i)
11163
11164
11165
11166
11167
11168         enddo
11169       enddo
11170 #else
11171       do i=0,nct
11172         do j=1,3
11173           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11174                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11175                       welec*gelc_long(j,i)+ &
11176                       wbond*gradb(j,i)+ &
11177                       wel_loc*gel_loc_long(j,i)+ &
11178                       wcorr*gradcorr_long(j,i)+ &
11179                       wcorr5*gradcorr5_long(j,i)+ &
11180                       wcorr6*gradcorr6_long(j,i)+ &
11181                       wturn6*gcorr6_turn_long(j,i)+ &
11182                       wstrain*ghpbc(j,i) &
11183                      +wliptran*gliptranc(j,i) &
11184                      +gradafm(j,i) &
11185                      +welec*gshieldc(j,i)&
11186                      +wcorr*gshieldc_ec(j,i) &
11187                      +wturn4*gshieldc_t4(j,i) &
11188                      +wel_loc*gshieldc_ll(j,i)&
11189                      +wtube*gg_tube(j,i) &
11190                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11191                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11192                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11193                      wcorr_nucl*gradcorr_nucl(j,i) &
11194                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
11195                      wcatprot* gradpepcat(j,i)+ &
11196                      wcatcat*gradcatcat(j,i)+   &
11197                      wscbase*gvdwc_scbase(j,i)+ &
11198                      wpepbase*gvdwc_pepbase(j,i)+&
11199                      wscpho*gvdwc_scpho(j,i)+&
11200                      wpeppho*gvdwc_peppho(j,i)+wcatnucl*gradnuclcat(j,i)
11201
11202
11203         enddo
11204       enddo
11205 #endif
11206 #ifdef MPI
11207       if (nfgtasks.gt.1) then
11208       time00=MPI_Wtime()
11209 #ifdef DEBUG
11210       write (iout,*) "gradbufc before allreduce"
11211       do i=1,nres
11212         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11213       enddo
11214       call flush(iout)
11215 #endif
11216       do i=0,nres
11217         do j=1,3
11218           gradbufc_sum(j,i)=gradbufc(j,i)
11219         enddo
11220       enddo
11221 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
11222 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
11223 !      time_reduce=time_reduce+MPI_Wtime()-time00
11224 #ifdef DEBUG
11225 !      write (iout,*) "gradbufc_sum after allreduce"
11226 !      do i=1,nres
11227 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
11228 !      enddo
11229 !      call flush(iout)
11230 #endif
11231 #ifdef TIMING
11232 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
11233 #endif
11234       do i=0,nres
11235         do k=1,3
11236           gradbufc(k,i)=0.0d0
11237         enddo
11238       enddo
11239 #ifdef DEBUG
11240       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
11241       write (iout,*) (i," jgrad_start",jgrad_start(i),&
11242                         " jgrad_end  ",jgrad_end(i),&
11243                         i=igrad_start,igrad_end)
11244 #endif
11245 !
11246 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
11247 ! do not parallelize this part.
11248 !
11249 !      do i=igrad_start,igrad_end
11250 !        do j=jgrad_start(i),jgrad_end(i)
11251 !          do k=1,3
11252 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
11253 !          enddo
11254 !        enddo
11255 !      enddo
11256       do j=1,3
11257         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11258       enddo
11259       do i=nres-2,-1,-1
11260         do j=1,3
11261           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11262         enddo
11263       enddo
11264 #ifdef DEBUG
11265       write (iout,*) "gradbufc after summing"
11266       do i=1,nres
11267         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11268       enddo
11269       call flush(iout)
11270 #endif
11271       else
11272 #endif
11273 !el#define DEBUG
11274 #ifdef DEBUG
11275       write (iout,*) "gradbufc"
11276       do i=1,nres
11277         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11278       enddo
11279       call flush(iout)
11280 #endif
11281 !el#undef DEBUG
11282       do i=-1,nres
11283         do j=1,3
11284           gradbufc_sum(j,i)=gradbufc(j,i)
11285           gradbufc(j,i)=0.0d0
11286         enddo
11287       enddo
11288       do j=1,3
11289         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11290       enddo
11291       do i=nres-2,-1,-1
11292         do j=1,3
11293           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11294         enddo
11295       enddo
11296 !      do i=nnt,nres-1
11297 !        do k=1,3
11298 !          gradbufc(k,i)=0.0d0
11299 !        enddo
11300 !        do j=i+1,nres
11301 !          do k=1,3
11302 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
11303 !          enddo
11304 !        enddo
11305 !      enddo
11306 !el#define DEBUG
11307 #ifdef DEBUG
11308       write (iout,*) "gradbufc after summing"
11309       do i=1,nres
11310         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11311       enddo
11312       call flush(iout)
11313 #endif
11314 !el#undef DEBUG
11315 #ifdef MPI
11316       endif
11317 #endif
11318       do k=1,3
11319         gradbufc(k,nres)=0.0d0
11320       enddo
11321 !el----------------
11322 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
11323 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
11324 !el-----------------
11325       do i=-1,nct
11326         do j=1,3
11327 #ifdef SPLITELE
11328           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11329                       wel_loc*gel_loc(j,i)+ &
11330                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11331                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11332                       wel_loc*gel_loc_long(j,i)+ &
11333                       wcorr*gradcorr_long(j,i)+ &
11334                       wcorr5*gradcorr5_long(j,i)+ &
11335                       wcorr6*gradcorr6_long(j,i)+ &
11336                       wturn6*gcorr6_turn_long(j,i))+ &
11337                       wbond*gradb(j,i)+ &
11338                       wcorr*gradcorr(j,i)+ &
11339                       wturn3*gcorr3_turn(j,i)+ &
11340                       wturn4*gcorr4_turn(j,i)+ &
11341                       wcorr5*gradcorr5(j,i)+ &
11342                       wcorr6*gradcorr6(j,i)+ &
11343                       wturn6*gcorr6_turn(j,i)+ &
11344                       wsccor*gsccorc(j,i) &
11345                      +wscloc*gscloc(j,i)  &
11346                      +wliptran*gliptranc(j,i) &
11347                      +gradafm(j,i) &
11348                      +welec*gshieldc(j,i) &
11349                      +welec*gshieldc_loc(j,i) &
11350                      +wcorr*gshieldc_ec(j,i) &
11351                      +wcorr*gshieldc_loc_ec(j,i) &
11352                      +wturn3*gshieldc_t3(j,i) &
11353                      +wturn3*gshieldc_loc_t3(j,i) &
11354                      +wturn4*gshieldc_t4(j,i) &
11355                      +wturn4*gshieldc_loc_t4(j,i) &
11356                      +wel_loc*gshieldc_ll(j,i) &
11357                      +wel_loc*gshieldc_loc_ll(j,i) &
11358                      +wtube*gg_tube(j,i) &
11359                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11360                      +wvdwpsb*gvdwpsb1(j,i))&
11361                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
11362 !                      if (i.eq.21) then
11363 !                      print *,"in sum",gradc(j,i,icg),wturn4*gcorr4_turn(j,i),&
11364 !                      wturn4*gshieldc_t4(j,i), &
11365 !                     wturn4*gshieldc_loc_t4(j,i)
11366 !                       endif
11367 !                 if ((i.le.2).and.(i.ge.1))
11368 !                       print *,gradc(j,i,icg),&
11369 !                      gradbufc(j,i),welec*gelc(j,i), &
11370 !                      wel_loc*gel_loc(j,i), &
11371 !                      wscp*gvdwc_scpp(j,i), &
11372 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
11373 !                      wel_loc*gel_loc_long(j,i), &
11374 !                      wcorr*gradcorr_long(j,i), &
11375 !                      wcorr5*gradcorr5_long(j,i), &
11376 !                      wcorr6*gradcorr6_long(j,i), &
11377 !                      wturn6*gcorr6_turn_long(j,i), &
11378 !                      wbond*gradb(j,i), &
11379 !                      wcorr*gradcorr(j,i), &
11380 !                      wturn3*gcorr3_turn(j,i), &
11381 !                      wturn4*gcorr4_turn(j,i), &
11382 !                      wcorr5*gradcorr5(j,i), &
11383 !                      wcorr6*gradcorr6(j,i), &
11384 !                      wturn6*gcorr6_turn(j,i), &
11385 !                      wsccor*gsccorc(j,i) &
11386 !                     ,wscloc*gscloc(j,i)  &
11387 !                     ,wliptran*gliptranc(j,i) &
11388 !                    ,gradafm(j,i) &
11389 !                     ,welec*gshieldc(j,i) &
11390 !                     ,welec*gshieldc_loc(j,i) &
11391 !                     ,wcorr*gshieldc_ec(j,i) &
11392 !                     ,wcorr*gshieldc_loc_ec(j,i) &
11393 !                     ,wturn3*gshieldc_t3(j,i) &
11394 !                     ,wturn3*gshieldc_loc_t3(j,i) &
11395 !                     ,wturn4*gshieldc_t4(j,i) &
11396 !                     ,wturn4*gshieldc_loc_t4(j,i) &
11397 !                     ,wel_loc*gshieldc_ll(j,i) &
11398 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
11399 !                     ,wtube*gg_tube(j,i) &
11400 !                     ,wbond_nucl*gradb_nucl(j,i) &
11401 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
11402 !                     wvdwpsb*gvdwpsb1(j,i)&
11403 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
11404 !
11405
11406 #else
11407           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11408                       wel_loc*gel_loc(j,i)+ &
11409                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11410                       welec*gelc_long(j,i)+ &
11411                       wel_loc*gel_loc_long(j,i)+ &
11412 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
11413                       wcorr5*gradcorr5_long(j,i)+ &
11414                       wcorr6*gradcorr6_long(j,i)+ &
11415                       wturn6*gcorr6_turn_long(j,i))+ &
11416                       wbond*gradb(j,i)+ &
11417                       wcorr*gradcorr(j,i)+ &
11418                       wturn3*gcorr3_turn(j,i)+ &
11419                       wturn4*gcorr4_turn(j,i)+ &
11420                       wcorr5*gradcorr5(j,i)+ &
11421                       wcorr6*gradcorr6(j,i)+ &
11422                       wturn6*gcorr6_turn(j,i)+ &
11423                       wsccor*gsccorc(j,i) &
11424                      +wscloc*gscloc(j,i) &
11425                      +gradafm(j,i) &
11426                      +wliptran*gliptranc(j,i) &
11427                      +welec*gshieldc(j,i) &
11428                      +welec*gshieldc_loc(j,i) &
11429                      +wcorr*gshieldc_ec(j,i) &
11430                      +wcorr*gshieldc_loc_ec(j,i) &
11431                      +wturn3*gshieldc_t3(j,i) &
11432                      +wturn3*gshieldc_loc_t3(j,i) &
11433                      +wturn4*gshieldc_t4(j,i) &
11434                      +wturn4*gshieldc_loc_t4(j,i) &
11435                      +wel_loc*gshieldc_ll(j,i) &
11436                      +wel_loc*gshieldc_loc_ll(j,i) &
11437                      +wtube*gg_tube(j,i) &
11438                      +wbond_nucl*gradb_nucl(j,i) &
11439                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11440                      +wvdwpsb*gvdwpsb1(j,i))&
11441                      +wsbloc*gsbloc(j,i)+wcatnucl*gradnuclcat(j,i)
11442
11443
11444
11445
11446 #endif
11447           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
11448                         wbond*gradbx(j,i)+ &
11449                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
11450                         wsccor*gsccorx(j,i) &
11451                        +wscloc*gsclocx(j,i) &
11452                        +wliptran*gliptranx(j,i) &
11453                        +welec*gshieldx(j,i)     &
11454                        +wcorr*gshieldx_ec(j,i)  &
11455                        +wturn3*gshieldx_t3(j,i) &
11456                        +wturn4*gshieldx_t4(j,i) &
11457                        +wel_loc*gshieldx_ll(j,i)&
11458                        +wtube*gg_tube_sc(j,i)   &
11459                        +wbond_nucl*gradbx_nucl(j,i) &
11460                        +wvdwsb*gvdwsbx(j,i) &
11461                        +welsb*gelsbx(j,i) &
11462                        +wcorr_nucl*gradxorr_nucl(j,i)&
11463                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
11464                        +wsbloc*gsblocx(j,i) &
11465                        +wcatprot* gradpepcatx(j,i)&
11466                        +wscbase*gvdwx_scbase(j,i) &
11467                        +wpepbase*gvdwx_pepbase(j,i)&
11468                        +wscpho*gvdwx_scpho(j,i)+wcatnucl*gradnuclcatx(j,i)
11469 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
11470
11471         enddo
11472       enddo
11473 !#define DEBUG
11474 #ifdef DEBUG
11475       write (iout,*) "gloc before adding corr"
11476       do i=1,4*nres
11477         write (iout,*) i,gloc(i,icg)
11478       enddo
11479 #endif
11480       do i=1,nres-3
11481         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
11482          +wcorr5*g_corr5_loc(i) &
11483          +wcorr6*g_corr6_loc(i) &
11484          +wturn4*gel_loc_turn4(i) &
11485          +wturn3*gel_loc_turn3(i) &
11486          +wturn6*gel_loc_turn6(i) &
11487          +wel_loc*gel_loc_loc(i)
11488       enddo
11489 #ifdef DEBUG
11490       write (iout,*) "gloc after adding corr"
11491       do i=1,4*nres
11492         write (iout,*) i,gloc(i,icg)
11493       enddo
11494 #endif
11495 !#undef DEBUG
11496 #ifdef MPI
11497       if (nfgtasks.gt.1) then
11498         do j=1,3
11499           do i=0,nres
11500             gradbufc(j,i)=gradc(j,i,icg)
11501             gradbufx(j,i)=gradx(j,i,icg)
11502           enddo
11503         enddo
11504         do i=1,4*nres
11505           glocbuf(i)=gloc(i,icg)
11506         enddo
11507 !#define DEBUG
11508 #ifdef DEBUG
11509       write (iout,*) "gloc_sc before reduce"
11510       do i=1,nres
11511        do j=1,1
11512         write (iout,*) i,j,gloc_sc(j,i,icg)
11513        enddo
11514       enddo
11515 #endif
11516 !#undef DEBUG
11517         do i=0,nres
11518          do j=1,3
11519           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
11520          enddo
11521         enddo
11522         time00=MPI_Wtime()
11523         call MPI_Barrier(FG_COMM,IERR)
11524         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
11525         time00=MPI_Wtime()
11526         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
11527           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11528         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
11529           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11530         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
11531           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11532         time_reduce=time_reduce+MPI_Wtime()-time00
11533         call MPI_Reduce(gloc_scbuf(1,0),gloc_sc(1,0,icg),3*nres+3,&
11534           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11535         time_reduce=time_reduce+MPI_Wtime()-time00
11536 !#define DEBUG
11537 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
11538 #ifdef DEBUG
11539       write (iout,*) "gloc_sc after reduce"
11540       do i=0,nres
11541        do j=1,1
11542         write (iout,*) i,j,gloc_sc(j,i,icg)
11543        enddo
11544       enddo
11545 #endif
11546 !#undef DEBUG
11547 #ifdef DEBUG
11548       write (iout,*) "gloc after reduce"
11549       do i=1,4*nres
11550         write (iout,*) i,gloc(i,icg)
11551       enddo
11552 #endif
11553       endif
11554 #endif
11555       if (gnorm_check) then
11556 !
11557 ! Compute the maximum elements of the gradient
11558 !
11559       gvdwc_max=0.0d0
11560       gvdwc_scp_max=0.0d0
11561       gelc_max=0.0d0
11562       gvdwpp_max=0.0d0
11563       gradb_max=0.0d0
11564       ghpbc_max=0.0d0
11565       gradcorr_max=0.0d0
11566       gel_loc_max=0.0d0
11567       gcorr3_turn_max=0.0d0
11568       gcorr4_turn_max=0.0d0
11569       gradcorr5_max=0.0d0
11570       gradcorr6_max=0.0d0
11571       gcorr6_turn_max=0.0d0
11572       gsccorc_max=0.0d0
11573       gscloc_max=0.0d0
11574       gvdwx_max=0.0d0
11575       gradx_scp_max=0.0d0
11576       ghpbx_max=0.0d0
11577       gradxorr_max=0.0d0
11578       gsccorx_max=0.0d0
11579       gsclocx_max=0.0d0
11580       do i=1,nct
11581         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
11582         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
11583         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
11584         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
11585          gvdwc_scp_max=gvdwc_scp_norm
11586         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
11587         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
11588         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
11589         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
11590         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
11591         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
11592         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
11593         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
11594         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
11595         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
11596         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
11597         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
11598         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
11599           gcorr3_turn(1,i)))
11600         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
11601           gcorr3_turn_max=gcorr3_turn_norm
11602         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
11603           gcorr4_turn(1,i)))
11604         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
11605           gcorr4_turn_max=gcorr4_turn_norm
11606         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
11607         if (gradcorr5_norm.gt.gradcorr5_max) &
11608           gradcorr5_max=gradcorr5_norm
11609         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
11610         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
11611         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
11612           gcorr6_turn(1,i)))
11613         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
11614           gcorr6_turn_max=gcorr6_turn_norm
11615         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
11616         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
11617         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
11618         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
11619         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
11620         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
11621         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
11622         if (gradx_scp_norm.gt.gradx_scp_max) &
11623           gradx_scp_max=gradx_scp_norm
11624         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
11625         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
11626         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
11627         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
11628         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
11629         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
11630         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
11631         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
11632       enddo
11633       if (gradout) then
11634 #ifdef AIX
11635         open(istat,file=statname,position="append")
11636 #else
11637         open(istat,file=statname,access="append")
11638 #endif
11639         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
11640            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
11641            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
11642            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
11643            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
11644            gsccorx_max,gsclocx_max
11645         close(istat)
11646         if (gvdwc_max.gt.1.0d4) then
11647           write (iout,*) "gvdwc gvdwx gradb gradbx"
11648           do i=nnt,nct
11649             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
11650               gradb(j,i),gradbx(j,i),j=1,3)
11651           enddo
11652           call pdbout(0.0d0,'cipiszcze',iout)
11653           call flush(iout)
11654         endif
11655       endif
11656       endif
11657 !#define DEBUG
11658 #ifdef DEBUG
11659       write (iout,*) "gradc gradx gloc"
11660       do i=1,nres
11661         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
11662          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
11663       enddo
11664 #endif
11665 !#undef DEBUG
11666 #ifdef TIMING
11667       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
11668 #endif
11669       return
11670       end subroutine sum_gradient
11671 !-----------------------------------------------------------------------------
11672       subroutine sc_grad
11673 !      implicit real*8 (a-h,o-z)
11674       use calc_data
11675 !      include 'DIMENSIONS'
11676 !      include 'COMMON.CHAIN'
11677 !      include 'COMMON.DERIV'
11678 !      include 'COMMON.CALC'
11679 !      include 'COMMON.IOUNITS'
11680       real(kind=8), dimension(3) :: dcosom1,dcosom2
11681 !      print *,"wchodze"
11682       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11683           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11684       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11685           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11686
11687       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11688            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11689            +dCAVdOM12+ dGCLdOM12
11690 ! diagnostics only
11691 !      eom1=0.0d0
11692 !      eom2=0.0d0
11693 !      eom12=evdwij*eps1_om12
11694 ! end diagnostics
11695 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
11696 !       " sigder",sigder
11697 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
11698 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
11699 !C      print *,sss_ele_cut,'in sc_grad'
11700       do k=1,3
11701         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11702         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
11703       enddo
11704       do k=1,3
11705         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
11706 !C      print *,'gg',k,gg(k)
11707        enddo
11708 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11709 !      write (iout,*) "gg",(gg(k),k=1,3)
11710       do k=1,3
11711         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
11712                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11713                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
11714                   *sss_ele_cut
11715
11716         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
11717                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11718                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
11719                   *sss_ele_cut
11720
11721 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11722 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11723 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11724 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11725       enddo
11726 !
11727 ! Calculate the components of the gradient in DC and X
11728 !
11729 !grad      do k=i,j-1
11730 !grad        do l=1,3
11731 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
11732 !grad        enddo
11733 !grad      enddo
11734       do l=1,3
11735         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
11736         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
11737       enddo
11738       return
11739       end subroutine sc_grad
11740
11741       subroutine sc_grad_cat
11742       use calc_data
11743       real(kind=8), dimension(3) :: dcosom1,dcosom2
11744       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11745           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11746       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11747           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11748
11749       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11750            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11751            +dCAVdOM12+ dGCLdOM12
11752 ! diagnostics only
11753 !      eom1=0.0d0
11754 !      eom2=0.0d0
11755 !      eom12=evdwij*eps1_om12
11756 ! end diagnostics
11757
11758       do k=1,3
11759         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11760         dcosom2(k)=rij*(dc_norm(k,j)-om2*erij(k))
11761       enddo
11762       do k=1,3
11763         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))
11764 !C      print *,'gg',k,gg(k)
11765        enddo
11766 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11767 !      write (iout,*) "gg",(gg(k),k=1,3)
11768       do k=1,3
11769         gradpepcatx(k,i)=gradpepcatx(k,i)-gg(k) &
11770                   +(eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
11771                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11772
11773 !        gradpepcatx(k,j)=gradpepcatx(k,j)+gg(k) &
11774 !                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)) &
11775 !                  +eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv
11776
11777 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11778 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11779 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11780 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11781       enddo
11782 !
11783 ! Calculate the components of the gradient in DC and X
11784 !
11785       do l=1,3
11786         gradpepcat(l,i)=gradpepcat(l,i)-gg(l)
11787         gradpepcat(l,j)=gradpepcat(l,j)+gg(l)
11788       enddo
11789       end subroutine sc_grad_cat
11790
11791       subroutine sc_grad_cat_pep
11792       use calc_data
11793       real(kind=8), dimension(3) :: dcosom1,dcosom2
11794       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11795           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11796       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11797           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11798
11799       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11800            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11801            +dCAVdOM12+ dGCLdOM12
11802 ! diagnostics only
11803 !      eom1=0.0d0
11804 !      eom2=0.0d0
11805 !      eom12=evdwij*eps1_om12
11806 ! end diagnostics
11807
11808       do k=1,3
11809         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
11810         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
11811         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
11812         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
11813                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
11814                  *dsci_inv*2.0 &
11815                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
11816         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
11817                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
11818                  *dsci_inv*2.0 &
11819                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
11820         gradpepcat(k,j)=gradpepcat(k,j)+gg(k)
11821       enddo
11822       end subroutine sc_grad_cat_pep
11823
11824 #ifdef CRYST_THETA
11825 !-----------------------------------------------------------------------------
11826       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
11827
11828       use comm_calcthet
11829 !      implicit real*8 (a-h,o-z)
11830 !      include 'DIMENSIONS'
11831 !      include 'COMMON.LOCAL'
11832 !      include 'COMMON.IOUNITS'
11833 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
11834 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11835 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
11836       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
11837       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
11838 !el      integer :: it
11839 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
11840 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11841 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
11842 !el local variables
11843
11844       delthec=thetai-thet_pred_mean
11845       delthe0=thetai-theta0i
11846 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
11847       t3 = thetai-thet_pred_mean
11848       t6 = t3**2
11849       t9 = term1
11850       t12 = t3*sigcsq
11851       t14 = t12+t6*sigsqtc
11852       t16 = 1.0d0
11853       t21 = thetai-theta0i
11854       t23 = t21**2
11855       t26 = term2
11856       t27 = t21*t26
11857       t32 = termexp
11858       t40 = t32**2
11859       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
11860        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
11861        *(-t12*t9-ak*sig0inv*t27)
11862       return
11863       end subroutine mixder
11864 #endif
11865 !-----------------------------------------------------------------------------
11866 ! cartder.F
11867 !-----------------------------------------------------------------------------
11868       subroutine cartder
11869 !-----------------------------------------------------------------------------
11870 ! This subroutine calculates the derivatives of the consecutive virtual
11871 ! bond vectors and the SC vectors in the virtual-bond angles theta and
11872 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
11873 ! in the angles alpha and omega, describing the location of a side chain
11874 ! in its local coordinate system.
11875 !
11876 ! The derivatives are stored in the following arrays:
11877 !
11878 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
11879 ! The structure is as follows:
11880 !
11881 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
11882 ! dDC(x,3)/dT(4),...,dDC(z,3)/dT(4),dDC(x,3)/dP(4),dDC(y,4)/dP(4),dDC(z,4)/dP(4)
11883 !         . . . . . . . . . . . .  . . . . . .
11884 ! dDC(x,N-1)/dT(4),...,dDC(z,N-1)/dT(4),dDC(x,N-1)/dP(4),dDC(y,N-1)/dP(4),dDC(z,N-1)/dP(4)
11885 !                          .
11886 !                          .
11887 !                          .
11888 ! dDC(x,N-1)/dT(N),...,dDC(z,N-1)/dT(N),dDC(x,N-1)/dP(N),dDC(y,N-1)/dP(N),dDC(z,N-1)/dP(N)
11889 !
11890 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
11891 ! The structure is same as above.
11892 !
11893 ! DCDS - the derivatives of the side chain vectors in the local spherical
11894 ! andgles alph and omega:
11895 !
11896 ! dX(x,2)/dA(2),dX(y,2)/dA(2),dX(z,2)/dA(2),dX(x,2)/dO(2),dX(y,2)/dO(2),dX(z,2)/dO(2)
11897 ! dX(x,3)/dA(3),dX(y,3)/dA(3),dX(z,3)/dA(3),dX(x,3)/dO(3),dX(y,3)/dO(3),dX(z,3)/dO(3)
11898 !                          .
11899 !                          .
11900 !                          .
11901 ! dX(x,N-1)/dA(N-1),dX(y,N-1)/dA(N-1),dX(z,N-1)/dA(N-1),dX(x,N-1)/dO(N-1),dX(y,N-1)/dO(N-1),dX(z,N-1)/dO(N-1)
11902 !
11903 ! Version of March '95, based on an early version of November '91.
11904 !
11905 !**********************************************************************
11906 !      implicit real*8 (a-h,o-z)
11907 !      include 'DIMENSIONS'
11908 !      include 'COMMON.VAR'
11909 !      include 'COMMON.CHAIN'
11910 !      include 'COMMON.DERIV'
11911 !      include 'COMMON.GEO'
11912 !      include 'COMMON.LOCAL'
11913 !      include 'COMMON.INTERACT'
11914       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
11915       real(kind=8),dimension(3,3) :: dp,temp
11916 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
11917       real(kind=8),dimension(3) :: xx,xx1
11918 !el local variables
11919       integer :: i,k,l,j,m,ind,ind1,jjj
11920       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
11921                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
11922                  sint2,xp,yp,xxp,yyp,zzp,dj
11923
11924 !      common /przechowalnia/ fromto
11925       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
11926 ! get the position of the jth ijth fragment of the chain coordinate system
11927 ! in the fromto array.
11928 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11929 !
11930 !      maxdim=(nres-1)*(nres-2)/2
11931 !      allocate(dcdv(6,maxdim),dxds(6,nres))
11932 ! calculate the derivatives of transformation matrix elements in theta
11933 !
11934
11935 !el      call flush(iout) !el
11936       do i=1,nres-2
11937         rdt(1,1,i)=-rt(1,2,i)
11938         rdt(1,2,i)= rt(1,1,i)
11939         rdt(1,3,i)= 0.0d0
11940         rdt(2,1,i)=-rt(2,2,i)
11941         rdt(2,2,i)= rt(2,1,i)
11942         rdt(2,3,i)= 0.0d0
11943         rdt(3,1,i)=-rt(3,2,i)
11944         rdt(3,2,i)= rt(3,1,i)
11945         rdt(3,3,i)= 0.0d0
11946       enddo
11947 !
11948 ! derivatives in phi
11949 !
11950       do i=2,nres-2
11951         drt(1,1,i)= 0.0d0
11952         drt(1,2,i)= 0.0d0
11953         drt(1,3,i)= 0.0d0
11954         drt(2,1,i)= rt(3,1,i)
11955         drt(2,2,i)= rt(3,2,i)
11956         drt(2,3,i)= rt(3,3,i)
11957         drt(3,1,i)=-rt(2,1,i)
11958         drt(3,2,i)=-rt(2,2,i)
11959         drt(3,3,i)=-rt(2,3,i)
11960       enddo
11961 !
11962 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
11963 !
11964       do i=2,nres-2
11965         ind=indmat(i,i+1)
11966         do k=1,3
11967           do l=1,3
11968             temp(k,l)=rt(k,l,i)
11969           enddo
11970         enddo
11971         do k=1,3
11972           do l=1,3
11973             fromto(k,l,ind)=temp(k,l)
11974           enddo
11975         enddo
11976         do j=i+1,nres-2
11977           ind=indmat(i,j+1)
11978           do k=1,3
11979             do l=1,3
11980               dpkl=0.0d0
11981               do m=1,3
11982                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
11983               enddo
11984               dp(k,l)=dpkl
11985               fromto(k,l,ind)=dpkl
11986             enddo
11987           enddo
11988           do k=1,3
11989             do l=1,3
11990               temp(k,l)=dp(k,l)
11991             enddo
11992           enddo
11993         enddo
11994       enddo
11995 !
11996 ! Calculate derivatives.
11997 !
11998       ind1=0
11999       do i=1,nres-2
12000       ind1=ind1+1
12001 !
12002 ! Derivatives of DC(i+1) in theta(i+2)
12003 !
12004         do j=1,3
12005           do k=1,2
12006             dpjk=0.0D0
12007             do l=1,3
12008               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
12009             enddo
12010             dp(j,k)=dpjk
12011             prordt(j,k,i)=dp(j,k)
12012           enddo
12013           dp(j,3)=0.0D0
12014           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
12015         enddo
12016 !
12017 ! Derivatives of SC(i+1) in theta(i+2)
12018 !
12019         xx1(1)=-0.5D0*xloc(2,i+1)
12020         xx1(2)= 0.5D0*xloc(1,i+1)
12021         do j=1,3
12022           xj=0.0D0
12023           do k=1,2
12024             xj=xj+r(j,k,i)*xx1(k)
12025           enddo
12026           xx(j)=xj
12027         enddo
12028         do j=1,3
12029           rj=0.0D0
12030           do k=1,3
12031             rj=rj+prod(j,k,i)*xx(k)
12032           enddo
12033           dxdv(j,ind1)=rj
12034         enddo
12035 !
12036 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
12037 ! than the other off-diagonal derivatives.
12038 !
12039         do j=1,3
12040           dxoiij=0.0D0
12041           do k=1,3
12042             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12043           enddo
12044           dxdv(j,ind1+1)=dxoiij
12045         enddo
12046 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
12047 !
12048 ! Derivatives of DC(i+1) in phi(i+2)
12049 !
12050         do j=1,3
12051           do k=1,3
12052             dpjk=0.0
12053             do l=2,3
12054               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
12055             enddo
12056             dp(j,k)=dpjk
12057             prodrt(j,k,i)=dp(j,k)
12058           enddo
12059           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
12060         enddo
12061 !
12062 ! Derivatives of SC(i+1) in phi(i+2)
12063 !
12064         xx(1)= 0.0D0
12065         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
12066         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
12067         do j=1,3
12068           rj=0.0D0
12069           do k=2,3
12070             rj=rj+prod(j,k,i)*xx(k)
12071           enddo
12072           dxdv(j+3,ind1)=-rj
12073         enddo
12074 !
12075 ! Derivatives of SC(i+1) in phi(i+3).
12076 !
12077         do j=1,3
12078           dxoiij=0.0D0
12079           do k=1,3
12080             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12081           enddo
12082           dxdv(j+3,ind1+1)=dxoiij
12083         enddo
12084 !
12085 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
12086 ! theta(nres) and phi(i+3) thru phi(nres).
12087 !
12088         do j=i+1,nres-2
12089         ind1=ind1+1
12090         ind=indmat(i+1,j+1)
12091 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
12092           do k=1,3
12093             do l=1,3
12094               tempkl=0.0D0
12095               do m=1,2
12096                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
12097               enddo
12098               temp(k,l)=tempkl
12099             enddo
12100           enddo
12101 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
12102 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
12103 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
12104 ! Derivatives of virtual-bond vectors in theta
12105           do k=1,3
12106             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
12107           enddo
12108 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
12109 ! Derivatives of SC vectors in theta
12110           do k=1,3
12111             dxoijk=0.0D0
12112             do l=1,3
12113               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12114             enddo
12115             dxdv(k,ind1+1)=dxoijk
12116           enddo
12117 !
12118 !--- Calculate the derivatives in phi
12119 !
12120           do k=1,3
12121             do l=1,3
12122               tempkl=0.0D0
12123               do m=1,3
12124                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
12125               enddo
12126               temp(k,l)=tempkl
12127             enddo
12128           enddo
12129           do k=1,3
12130             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
12131         enddo
12132           do k=1,3
12133             dxoijk=0.0D0
12134             do l=1,3
12135               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12136             enddo
12137             dxdv(k+3,ind1+1)=dxoijk
12138           enddo
12139         enddo
12140       enddo
12141 !
12142 ! Derivatives in alpha and omega:
12143 !
12144       do i=2,nres-1
12145 !       dsci=dsc(itype(i,1))
12146         dsci=vbld(i+nres)
12147 #ifdef OSF
12148         alphi=alph(i)
12149         omegi=omeg(i)
12150         if(alphi.ne.alphi) alphi=100.0
12151         if(omegi.ne.omegi) omegi=-100.0
12152 #else
12153       alphi=alph(i)
12154       omegi=omeg(i)
12155 #endif
12156 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
12157       cosalphi=dcos(alphi)
12158       sinalphi=dsin(alphi)
12159       cosomegi=dcos(omegi)
12160       sinomegi=dsin(omegi)
12161       temp(1,1)=-dsci*sinalphi
12162       temp(2,1)= dsci*cosalphi*cosomegi
12163       temp(3,1)=-dsci*cosalphi*sinomegi
12164       temp(1,2)=0.0D0
12165       temp(2,2)=-dsci*sinalphi*sinomegi
12166       temp(3,2)=-dsci*sinalphi*cosomegi
12167       theta2=pi-0.5D0*theta(i+1)
12168       cost2=dcos(theta2)
12169       sint2=dsin(theta2)
12170       jjj=0
12171 !d      print *,((temp(l,k),l=1,3),k=1,2)
12172         do j=1,2
12173         xp=temp(1,j)
12174         yp=temp(2,j)
12175         xxp= xp*cost2+yp*sint2
12176         yyp=-xp*sint2+yp*cost2
12177         zzp=temp(3,j)
12178         xx(1)=xxp
12179         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
12180         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
12181         do k=1,3
12182           dj=0.0D0
12183           do l=1,3
12184             dj=dj+prod(k,l,i-1)*xx(l)
12185             enddo
12186           dxds(jjj+k,i)=dj
12187           enddo
12188         jjj=jjj+3
12189       enddo
12190       enddo
12191       return
12192       end subroutine cartder
12193 !-----------------------------------------------------------------------------
12194 ! checkder_p.F
12195 !-----------------------------------------------------------------------------
12196       subroutine check_cartgrad
12197 ! Check the gradient of Cartesian coordinates in internal coordinates.
12198 !      implicit real*8 (a-h,o-z)
12199 !      include 'DIMENSIONS'
12200 !      include 'COMMON.IOUNITS'
12201 !      include 'COMMON.VAR'
12202 !      include 'COMMON.CHAIN'
12203 !      include 'COMMON.GEO'
12204 !      include 'COMMON.LOCAL'
12205 !      include 'COMMON.DERIV'
12206       real(kind=8),dimension(6,nres) :: temp
12207       real(kind=8),dimension(3) :: xx,gg
12208       integer :: i,k,j,ii
12209       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
12210 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12211 !
12212 ! Check the gradient of the virtual-bond and SC vectors in the internal
12213 ! coordinates.
12214 !
12215       aincr=1.0d-6
12216       aincr2=5.0d-7
12217       call cartder
12218       write (iout,'(a)') '**************** dx/dalpha'
12219       write (iout,'(a)')
12220       do i=2,nres-1
12221       alphi=alph(i)
12222       alph(i)=alph(i)+aincr
12223       do k=1,3
12224         temp(k,i)=dc(k,nres+i)
12225         enddo
12226       call chainbuild
12227       do k=1,3
12228         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12229         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
12230         enddo
12231         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12232         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
12233         write (iout,'(a)')
12234       alph(i)=alphi
12235       call chainbuild
12236       enddo
12237       write (iout,'(a)')
12238       write (iout,'(a)') '**************** dx/domega'
12239       write (iout,'(a)')
12240       do i=2,nres-1
12241       omegi=omeg(i)
12242       omeg(i)=omeg(i)+aincr
12243       do k=1,3
12244         temp(k,i)=dc(k,nres+i)
12245         enddo
12246       call chainbuild
12247       do k=1,3
12248           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12249           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
12250                 (aincr*dabs(dxds(k+3,i))+aincr))
12251         enddo
12252         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12253             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
12254         write (iout,'(a)')
12255       omeg(i)=omegi
12256       call chainbuild
12257       enddo
12258       write (iout,'(a)')
12259       write (iout,'(a)') '**************** dx/dtheta'
12260       write (iout,'(a)')
12261       do i=3,nres
12262       theti=theta(i)
12263         theta(i)=theta(i)+aincr
12264         do j=i-1,nres-1
12265           do k=1,3
12266             temp(k,j)=dc(k,nres+j)
12267           enddo
12268         enddo
12269         call chainbuild
12270         do j=i-1,nres-1
12271         ii = indmat(i-2,j)
12272 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
12273         do k=1,3
12274           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12275           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
12276                   (aincr*dabs(dxdv(k,ii))+aincr))
12277           enddo
12278           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12279               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
12280           write(iout,'(a)')
12281         enddo
12282         write (iout,'(a)')
12283         theta(i)=theti
12284         call chainbuild
12285       enddo
12286       write (iout,'(a)') '***************** dx/dphi'
12287       write (iout,'(a)')
12288       do i=4,nres
12289         phi(i)=phi(i)+aincr
12290         do j=i-1,nres-1
12291           do k=1,3
12292             temp(k,j)=dc(k,nres+j)
12293           enddo
12294         enddo
12295         call chainbuild
12296         do j=i-1,nres-1
12297         ii = indmat(i-2,j)
12298 !         print *,'ii=',ii
12299         do k=1,3
12300           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12301             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
12302                   (aincr*dabs(dxdv(k+3,ii))+aincr))
12303           enddo
12304           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12305               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12306           write(iout,'(a)')
12307         enddo
12308         phi(i)=phi(i)-aincr
12309         call chainbuild
12310       enddo
12311       write (iout,'(a)') '****************** ddc/dtheta'
12312       do i=1,nres-2
12313         thet=theta(i+2)
12314         theta(i+2)=thet+aincr
12315         do j=i,nres
12316           do k=1,3
12317             temp(k,j)=dc(k,j)
12318           enddo
12319         enddo
12320         call chainbuild
12321         do j=i+1,nres-1
12322         ii = indmat(i,j)
12323 !         print *,'ii=',ii
12324         do k=1,3
12325           gg(k)=(dc(k,j)-temp(k,j))/aincr
12326           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
12327                  (aincr*dabs(dcdv(k,ii))+aincr))
12328           enddo
12329           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12330                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
12331         write (iout,'(a)')
12332         enddo
12333         do j=1,nres
12334           do k=1,3
12335             dc(k,j)=temp(k,j)
12336           enddo
12337         enddo
12338         theta(i+2)=thet
12339       enddo
12340       write (iout,'(a)') '******************* ddc/dphi'
12341       do i=1,nres-3
12342         phii=phi(i+3)
12343         phi(i+3)=phii+aincr
12344         do j=1,nres
12345           do k=1,3
12346             temp(k,j)=dc(k,j)
12347           enddo
12348         enddo
12349         call chainbuild
12350         do j=i+2,nres-1
12351         ii = indmat(i+1,j)
12352 !         print *,'ii=',ii
12353         do k=1,3
12354           gg(k)=(dc(k,j)-temp(k,j))/aincr
12355             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
12356                  (aincr*dabs(dcdv(k+3,ii))+aincr))
12357           enddo
12358           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12359                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12360         write (iout,'(a)')
12361         enddo
12362         do j=1,nres
12363           do k=1,3
12364             dc(k,j)=temp(k,j)
12365           enddo
12366         enddo
12367         phi(i+3)=phii
12368       enddo
12369       return
12370       end subroutine check_cartgrad
12371 !-----------------------------------------------------------------------------
12372       subroutine check_ecart
12373 ! Check the gradient of the energy in Cartesian coordinates.
12374 !     implicit real*8 (a-h,o-z)
12375 !     include 'DIMENSIONS'
12376 !     include 'COMMON.CHAIN'
12377 !     include 'COMMON.DERIV'
12378 !     include 'COMMON.IOUNITS'
12379 !     include 'COMMON.VAR'
12380 !     include 'COMMON.CONTACTS'
12381       use comm_srutu
12382 !el      integer :: icall
12383 !el      common /srutu/ icall
12384       real(kind=8),dimension(6) :: ggg
12385       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12386       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12387       real(kind=8),dimension(6,nres) :: grad_s
12388       real(kind=8),dimension(0:n_ene) :: energia,energia1
12389       integer :: uiparm(1)
12390       real(kind=8) :: urparm(1)
12391 !EL      external fdum
12392       integer :: nf,i,j,k
12393       real(kind=8) :: aincr,etot,etot1
12394       icg=1
12395       nf=0
12396       nfl=0
12397       call zerograd
12398       aincr=1.0D-5
12399       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
12400       nf=0
12401       icall=0
12402       call geom_to_var(nvar,x)
12403       call etotal(energia)
12404       etot=energia(0)
12405 !el      call enerprint(energia)
12406       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
12407       icall =1
12408       do i=1,nres
12409         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12410       enddo
12411       do i=1,nres
12412       do j=1,3
12413         grad_s(j,i)=gradc(j,i,icg)
12414         grad_s(j+3,i)=gradx(j,i,icg)
12415         enddo
12416       enddo
12417       call flush(iout)
12418       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12419       do i=1,nres
12420         do j=1,3
12421         xx(j)=c(j,i+nres)
12422         ddc(j)=dc(j,i)
12423         ddx(j)=dc(j,i+nres)
12424         enddo
12425       do j=1,3
12426         dc(j,i)=dc(j,i)+aincr
12427         do k=i+1,nres
12428           c(j,k)=c(j,k)+aincr
12429           c(j,k+nres)=c(j,k+nres)+aincr
12430           enddo
12431           call zerograd
12432           call etotal(energia1)
12433           etot1=energia1(0)
12434         ggg(j)=(etot1-etot)/aincr
12435         dc(j,i)=ddc(j)
12436         do k=i+1,nres
12437           c(j,k)=c(j,k)-aincr
12438           c(j,k+nres)=c(j,k+nres)-aincr
12439           enddo
12440         enddo
12441       do j=1,3
12442         c(j,i+nres)=c(j,i+nres)+aincr
12443         dc(j,i+nres)=dc(j,i+nres)+aincr
12444           call zerograd
12445           call etotal(energia1)
12446           etot1=energia1(0)
12447         ggg(j+3)=(etot1-etot)/aincr
12448         c(j,i+nres)=xx(j)
12449         dc(j,i+nres)=ddx(j)
12450         enddo
12451       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
12452          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
12453       enddo
12454       return
12455       end subroutine check_ecart
12456 #ifdef CARGRAD
12457 !-----------------------------------------------------------------------------
12458       subroutine check_ecartint
12459 ! Check the gradient of the energy in Cartesian coordinates.
12460       use io_base, only: intout
12461 !      implicit real*8 (a-h,o-z)
12462 !      include 'DIMENSIONS'
12463 !      include 'COMMON.CONTROL'
12464 !      include 'COMMON.CHAIN'
12465 !      include 'COMMON.DERIV'
12466 !      include 'COMMON.IOUNITS'
12467 !      include 'COMMON.VAR'
12468 !      include 'COMMON.CONTACTS'
12469 !      include 'COMMON.MD'
12470 !      include 'COMMON.LOCAL'
12471 !      include 'COMMON.SPLITELE'
12472       use comm_srutu
12473 !el      integer :: icall
12474 !el      common /srutu/ icall
12475       real(kind=8),dimension(6) :: ggg,ggg1
12476       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
12477       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12478       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
12479       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12480       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12481       real(kind=8),dimension(0:n_ene) :: energia,energia1
12482       integer :: uiparm(1)
12483       real(kind=8) :: urparm(1)
12484 !EL      external fdum
12485       integer :: i,j,k,nf
12486       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12487                    etot21,etot22
12488       r_cut=2.0d0
12489       rlambd=0.3d0
12490       icg=1
12491       nf=0
12492       nfl=0
12493       call intout
12494 !      call intcartderiv
12495 !      call checkintcartgrad
12496       call zerograd
12497       aincr=1.0D-5
12498       write(iout,*) 'Calling CHECK_ECARTINT.'
12499       nf=0
12500       icall=0
12501       call geom_to_var(nvar,x)
12502       write (iout,*) "split_ene ",split_ene
12503       call flush(iout)
12504       if (.not.split_ene) then
12505         call zerograd
12506         call etotal(energia)
12507         etot=energia(0)
12508         call cartgrad
12509         icall =1
12510         do i=1,nres
12511           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12512         enddo
12513         do j=1,3
12514           grad_s(j,0)=gcart(j,0)
12515         enddo
12516         do i=1,nres
12517           do j=1,3
12518             grad_s(j,i)=gcart(j,i)
12519             grad_s(j+3,i)=gxcart(j,i)
12520           enddo
12521         enddo
12522       else
12523 !- split gradient check
12524         call zerograd
12525         call etotal_long(energia)
12526 !el        call enerprint(energia)
12527         call cartgrad
12528         icall =1
12529         do i=1,nres
12530           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12531           (gxcart(j,i),j=1,3)
12532         enddo
12533         do j=1,3
12534           grad_s(j,0)=gcart(j,0)
12535         enddo
12536         do i=1,nres
12537           do j=1,3
12538             grad_s(j,i)=gcart(j,i)
12539             grad_s(j+3,i)=gxcart(j,i)
12540           enddo
12541         enddo
12542         call zerograd
12543         call etotal_short(energia)
12544         call enerprint(energia)
12545         call cartgrad
12546         icall =1
12547         do i=1,nres
12548           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12549           (gxcart(j,i),j=1,3)
12550         enddo
12551         do j=1,3
12552           grad_s1(j,0)=gcart(j,0)
12553         enddo
12554         do i=1,nres
12555           do j=1,3
12556             grad_s1(j,i)=gcart(j,i)
12557             grad_s1(j+3,i)=gxcart(j,i)
12558           enddo
12559         enddo
12560       endif
12561       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12562 !      do i=1,nres
12563       do i=nnt,nct
12564         do j=1,3
12565           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
12566           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
12567         ddc(j)=c(j,i)
12568         ddx(j)=c(j,i+nres)
12569           dcnorm_safe1(j)=dc_norm(j,i-1)
12570           dcnorm_safe2(j)=dc_norm(j,i)
12571           dxnorm_safe(j)=dc_norm(j,i+nres)
12572         enddo
12573       do j=1,3
12574         c(j,i)=ddc(j)+aincr
12575           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
12576           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
12577           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12578           dc(j,i)=c(j,i+1)-c(j,i)
12579           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12580           call int_from_cart1(.false.)
12581           if (.not.split_ene) then
12582            call zerograd
12583             call etotal(energia1)
12584             etot1=energia1(0)
12585             write (iout,*) "ij",i,j," etot1",etot1
12586           else
12587 !- split gradient
12588             call etotal_long(energia1)
12589             etot11=energia1(0)
12590             call etotal_short(energia1)
12591             etot12=energia1(0)
12592           endif
12593 !- end split gradient
12594 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12595         c(j,i)=ddc(j)-aincr
12596           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
12597           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
12598           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12599           dc(j,i)=c(j,i+1)-c(j,i)
12600           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12601           call int_from_cart1(.false.)
12602           if (.not.split_ene) then
12603             call zerograd
12604             call etotal(energia1)
12605             etot2=energia1(0)
12606             write (iout,*) "ij",i,j," etot2",etot2
12607           ggg(j)=(etot1-etot2)/(2*aincr)
12608           else
12609 !- split gradient
12610             call etotal_long(energia1)
12611             etot21=energia1(0)
12612           ggg(j)=(etot11-etot21)/(2*aincr)
12613             call etotal_short(energia1)
12614             etot22=energia1(0)
12615           ggg1(j)=(etot12-etot22)/(2*aincr)
12616 !- end split gradient
12617 !            write (iout,*) "etot21",etot21," etot22",etot22
12618           endif
12619 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12620         c(j,i)=ddc(j)
12621           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
12622           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
12623           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12624           dc(j,i)=c(j,i+1)-c(j,i)
12625           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12626           dc_norm(j,i-1)=dcnorm_safe1(j)
12627           dc_norm(j,i)=dcnorm_safe2(j)
12628           dc_norm(j,i+nres)=dxnorm_safe(j)
12629         enddo
12630       do j=1,3
12631         c(j,i+nres)=ddx(j)+aincr
12632           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12633           call int_from_cart1(.false.)
12634           if (.not.split_ene) then
12635             call zerograd
12636             call etotal(energia1)
12637             etot1=energia1(0)
12638           else
12639 !- split gradient
12640             call etotal_long(energia1)
12641             etot11=energia1(0)
12642             call etotal_short(energia1)
12643             etot12=energia1(0)
12644           endif
12645 !- end split gradient
12646         c(j,i+nres)=ddx(j)-aincr
12647           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12648           call int_from_cart1(.false.)
12649           if (.not.split_ene) then
12650            call zerograd
12651            call etotal(energia1)
12652             etot2=energia1(0)
12653           ggg(j+3)=(etot1-etot2)/(2*aincr)
12654           else
12655 !- split gradient
12656             call etotal_long(energia1)
12657             etot21=energia1(0)
12658           ggg(j+3)=(etot11-etot21)/(2*aincr)
12659             call etotal_short(energia1)
12660             etot22=energia1(0)
12661           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12662 !- end split gradient
12663           endif
12664 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12665         c(j,i+nres)=ddx(j)
12666           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12667           dc_norm(j,i+nres)=dxnorm_safe(j)
12668           call int_from_cart1(.false.)
12669         enddo
12670       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12671          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12672         if (split_ene) then
12673           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12674          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12675          k=1,6)
12676          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12677          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12678          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12679         endif
12680       enddo
12681       return
12682       end subroutine check_ecartint
12683 #else
12684 !-----------------------------------------------------------------------------
12685       subroutine check_ecartint
12686 ! Check the gradient of the energy in Cartesian coordinates.
12687       use io_base, only: intout
12688 !      implicit real*8 (a-h,o-z)
12689 !      include 'DIMENSIONS'
12690 !      include 'COMMON.CONTROL'
12691 !      include 'COMMON.CHAIN'
12692 !      include 'COMMON.DERIV'
12693 !      include 'COMMON.IOUNITS'
12694 !      include 'COMMON.VAR'
12695 !      include 'COMMON.CONTACTS'
12696 !      include 'COMMON.MD'
12697 !      include 'COMMON.LOCAL'
12698 !      include 'COMMON.SPLITELE'
12699       use comm_srutu
12700 !el      integer :: icall
12701 !el      common /srutu/ icall
12702       real(kind=8),dimension(6) :: ggg,ggg1
12703       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12704       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12705       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
12706       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12707       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12708       real(kind=8),dimension(0:n_ene) :: energia,energia1
12709       integer :: uiparm(1)
12710       real(kind=8) :: urparm(1)
12711 !EL      external fdum
12712       integer :: i,j,k,nf
12713       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12714                    etot21,etot22
12715       r_cut=2.0d0
12716       rlambd=0.3d0
12717       icg=1
12718       nf=0
12719       nfl=0
12720       call intout
12721 !      call intcartderiv
12722 !      call checkintcartgrad
12723       call zerograd
12724       aincr=1.0D-6
12725       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
12726       nf=0
12727       icall=0
12728       call geom_to_var(nvar,x)
12729       if (.not.split_ene) then
12730         call etotal(energia)
12731         etot=energia(0)
12732 !el        call enerprint(energia)
12733         call cartgrad
12734         icall =1
12735         do i=1,nres
12736           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12737         enddo
12738         do j=1,3
12739           grad_s(j,0)=gcart(j,0)
12740         enddo
12741         do i=1,nres
12742           do j=1,3
12743             grad_s(j,i)=gcart(j,i)
12744 !              if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12745
12746 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
12747             grad_s(j+3,i)=gxcart(j,i)
12748           enddo
12749         enddo
12750       else
12751 !- split gradient check
12752         call zerograd
12753         call etotal_long(energia)
12754 !el        call enerprint(energia)
12755         call cartgrad
12756         icall =1
12757         do i=1,nres
12758           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12759           (gxcart(j,i),j=1,3)
12760         enddo
12761         do j=1,3
12762           grad_s(j,0)=gcart(j,0)
12763         enddo
12764         do i=1,nres
12765           do j=1,3
12766             grad_s(j,i)=gcart(j,i)
12767 !            if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12768             grad_s(j+3,i)=gxcart(j,i)
12769           enddo
12770         enddo
12771         call zerograd
12772         call etotal_short(energia)
12773 !el        call enerprint(energia)
12774         call cartgrad
12775         icall =1
12776         do i=1,nres
12777           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12778           (gxcart(j,i),j=1,3)
12779         enddo
12780         do j=1,3
12781           grad_s1(j,0)=gcart(j,0)
12782         enddo
12783         do i=1,nres
12784           do j=1,3
12785             grad_s1(j,i)=gcart(j,i)
12786             grad_s1(j+3,i)=gxcart(j,i)
12787           enddo
12788         enddo
12789       endif
12790       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12791       do i=0,nres
12792         do j=1,3
12793         xx(j)=c(j,i+nres)
12794         ddc(j)=dc(j,i)
12795         ddx(j)=dc(j,i+nres)
12796           do k=1,3
12797             dcnorm_safe(k)=dc_norm(k,i)
12798             dxnorm_safe(k)=dc_norm(k,i+nres)
12799           enddo
12800         enddo
12801       do j=1,3
12802         dc(j,i)=ddc(j)+aincr
12803           call chainbuild_cart
12804 #ifdef MPI
12805 ! Broadcast the order to compute internal coordinates to the slaves.
12806 !          if (nfgtasks.gt.1)
12807 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12808 #endif
12809 !          call int_from_cart1(.false.)
12810           if (.not.split_ene) then
12811            call zerograd
12812             call etotal(energia1)
12813             etot1=energia1(0)
12814 !            call enerprint(energia1)
12815           else
12816 !- split gradient
12817             call etotal_long(energia1)
12818             etot11=energia1(0)
12819             call etotal_short(energia1)
12820             etot12=energia1(0)
12821 !            write (iout,*) "etot11",etot11," etot12",etot12
12822           endif
12823 !- end split gradient
12824 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12825         dc(j,i)=ddc(j)-aincr
12826           call chainbuild_cart
12827 !          call int_from_cart1(.false.)
12828           if (.not.split_ene) then
12829                   call zerograd
12830             call etotal(energia1)
12831             etot2=energia1(0)
12832           ggg(j)=(etot1-etot2)/(2*aincr)
12833           else
12834 !- split gradient
12835             call etotal_long(energia1)
12836             etot21=energia1(0)
12837           ggg(j)=(etot11-etot21)/(2*aincr)
12838             call etotal_short(energia1)
12839             etot22=energia1(0)
12840           ggg1(j)=(etot12-etot22)/(2*aincr)
12841 !- end split gradient
12842 !            write (iout,*) "etot21",etot21," etot22",etot22
12843           endif
12844 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12845         dc(j,i)=ddc(j)
12846           call chainbuild_cart
12847         enddo
12848       do j=1,3
12849         dc(j,i+nres)=ddx(j)+aincr
12850           call chainbuild_cart
12851 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
12852 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12853 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12854 !          write (iout,*) "dxnormnorm",dsqrt(
12855 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12856 !          write (iout,*) "dxnormnormsafe",dsqrt(
12857 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12858 !          write (iout,*)
12859           if (.not.split_ene) then
12860             call zerograd
12861             call etotal(energia1)
12862             etot1=energia1(0)
12863           else
12864 !- split gradient
12865             call etotal_long(energia1)
12866             etot11=energia1(0)
12867             call etotal_short(energia1)
12868             etot12=energia1(0)
12869           endif
12870 !- end split gradient
12871 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12872         dc(j,i+nres)=ddx(j)-aincr
12873           call chainbuild_cart
12874 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
12875 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12876 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12877 !          write (iout,*)
12878 !          write (iout,*) "dxnormnorm",dsqrt(
12879 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12880 !          write (iout,*) "dxnormnormsafe",dsqrt(
12881 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12882           if (.not.split_ene) then
12883             call zerograd
12884             call etotal(energia1)
12885             etot2=energia1(0)
12886           ggg(j+3)=(etot1-etot2)/(2*aincr)
12887           else
12888 !- split gradient
12889             call etotal_long(energia1)
12890             etot21=energia1(0)
12891           ggg(j+3)=(etot11-etot21)/(2*aincr)
12892             call etotal_short(energia1)
12893             etot22=energia1(0)
12894           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12895 !- end split gradient
12896           endif
12897 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12898         dc(j,i+nres)=ddx(j)
12899           call chainbuild_cart
12900         enddo
12901       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12902          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12903         if (split_ene) then
12904           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12905          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12906          k=1,6)
12907          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12908          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12909          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12910         endif
12911       enddo
12912       return
12913       end subroutine check_ecartint
12914 #endif
12915 !-----------------------------------------------------------------------------
12916       subroutine check_eint
12917 ! Check the gradient of energy in internal coordinates.
12918 !      implicit real*8 (a-h,o-z)
12919 !      include 'DIMENSIONS'
12920 !      include 'COMMON.CHAIN'
12921 !      include 'COMMON.DERIV'
12922 !      include 'COMMON.IOUNITS'
12923 !      include 'COMMON.VAR'
12924 !      include 'COMMON.GEO'
12925       use comm_srutu
12926 !el      integer :: icall
12927 !el      common /srutu/ icall
12928       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
12929       integer :: uiparm(1)
12930       real(kind=8) :: urparm(1)
12931       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
12932       character(len=6) :: key
12933 !EL      external fdum
12934       integer :: i,ii,nf
12935       real(kind=8) :: xi,aincr,etot,etot1,etot2
12936       call zerograd
12937       aincr=1.0D-7
12938       print '(a)','Calling CHECK_INT.'
12939       nf=0
12940       nfl=0
12941       icg=1
12942       call geom_to_var(nvar,x)
12943       call var_to_geom(nvar,x)
12944       call chainbuild
12945       icall=1
12946 !      print *,'ICG=',ICG
12947       call etotal(energia)
12948       etot = energia(0)
12949 !el      call enerprint(energia)
12950 !      print *,'ICG=',ICG
12951 #ifdef MPL
12952       if (MyID.ne.BossID) then
12953         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
12954         nf=x(nvar+1)
12955         nfl=x(nvar+2)
12956         icg=x(nvar+3)
12957       endif
12958 #endif
12959       nf=1
12960       nfl=3
12961 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
12962       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
12963 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
12964       icall=1
12965       do i=1,nvar
12966         xi=x(i)
12967         x(i)=xi-0.5D0*aincr
12968         call var_to_geom(nvar,x)
12969         call chainbuild
12970         call etotal(energia1)
12971         etot1=energia1(0)
12972         x(i)=xi+0.5D0*aincr
12973         call var_to_geom(nvar,x)
12974         call chainbuild
12975         call etotal(energia2)
12976         etot2=energia2(0)
12977         gg(i)=(etot2-etot1)/aincr
12978         write (iout,*) i,etot1,etot2
12979         x(i)=xi
12980       enddo
12981       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
12982           '     RelDiff*100% '
12983       do i=1,nvar
12984         if (i.le.nphi) then
12985           ii=i
12986           key = ' phi'
12987         else if (i.le.nphi+ntheta) then
12988           ii=i-nphi
12989           key=' theta'
12990         else if (i.le.nphi+ntheta+nside) then
12991            ii=i-(nphi+ntheta)
12992            key=' alpha'
12993         else
12994            ii=i-(nphi+ntheta+nside)
12995            key=' omega'
12996         endif
12997         write (iout,'(i3,a,i3,3(1pd16.6))') &
12998        i,key,ii,gg(i),gana(i),&
12999        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
13000       enddo
13001       return
13002       end subroutine check_eint
13003 !-----------------------------------------------------------------------------
13004 ! econstr_local.F
13005 !-----------------------------------------------------------------------------
13006       subroutine Econstr_back
13007 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
13008 !      implicit real*8 (a-h,o-z)
13009 !      include 'DIMENSIONS'
13010 !      include 'COMMON.CONTROL'
13011 !      include 'COMMON.VAR'
13012 !      include 'COMMON.MD'
13013       use MD_data
13014 !#ifndef LANG0
13015 !      include 'COMMON.LANGEVIN'
13016 !#else
13017 !      include 'COMMON.LANGEVIN.lang0'
13018 !#endif
13019 !      include 'COMMON.CHAIN'
13020 !      include 'COMMON.DERIV'
13021 !      include 'COMMON.GEO'
13022 !      include 'COMMON.LOCAL'
13023 !      include 'COMMON.INTERACT'
13024 !      include 'COMMON.IOUNITS'
13025 !      include 'COMMON.NAMES'
13026 !      include 'COMMON.TIME1'
13027       integer :: i,j,ii,k
13028       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
13029
13030       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
13031       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
13032       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
13033
13034       Uconst_back=0.0d0
13035       do i=1,nres
13036         dutheta(i)=0.0d0
13037         dugamma(i)=0.0d0
13038         do j=1,3
13039           duscdiff(j,i)=0.0d0
13040           duscdiffx(j,i)=0.0d0
13041         enddo
13042       enddo
13043       do i=1,nfrag_back
13044         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
13045 !
13046 ! Deviations from theta angles
13047 !
13048         utheta_i=0.0d0
13049         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
13050           dtheta_i=theta(j)-thetaref(j)
13051           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
13052           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
13053         enddo
13054         utheta(i)=utheta_i/(ii-1)
13055 !
13056 ! Deviations from gamma angles
13057 !
13058         ugamma_i=0.0d0
13059         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
13060           dgamma_i=pinorm(phi(j)-phiref(j))
13061 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
13062           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
13063           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
13064 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
13065         enddo
13066         ugamma(i)=ugamma_i/(ii-2)
13067 !
13068 ! Deviations from local SC geometry
13069 !
13070         uscdiff(i)=0.0d0
13071         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
13072           dxx=xxtab(j)-xxref(j)
13073           dyy=yytab(j)-yyref(j)
13074           dzz=zztab(j)-zzref(j)
13075           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
13076           do k=1,3
13077             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
13078              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
13079              (ii-1)
13080             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
13081              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
13082              (ii-1)
13083             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
13084            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
13085             /(ii-1)
13086           enddo
13087 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
13088 !     &      xxref(j),yyref(j),zzref(j)
13089         enddo
13090         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
13091 !        write (iout,*) i," uscdiff",uscdiff(i)
13092 !
13093 ! Put together deviations from local geometry
13094 !
13095         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
13096           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
13097 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
13098 !     &   " uconst_back",uconst_back
13099         utheta(i)=dsqrt(utheta(i))
13100         ugamma(i)=dsqrt(ugamma(i))
13101         uscdiff(i)=dsqrt(uscdiff(i))
13102       enddo
13103       return
13104       end subroutine Econstr_back
13105 !-----------------------------------------------------------------------------
13106 ! energy_p_new-sep_barrier.F
13107 !-----------------------------------------------------------------------------
13108       real(kind=8) function sscale(r)
13109 !      include "COMMON.SPLITELE"
13110       real(kind=8) :: r,gamm
13111       if(r.lt.r_cut-rlamb) then
13112         sscale=1.0d0
13113       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13114         gamm=(r-(r_cut-rlamb))/rlamb
13115         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13116       else
13117         sscale=0d0
13118       endif
13119       return
13120       end function sscale
13121       real(kind=8) function sscale_grad(r)
13122 !      include "COMMON.SPLITELE"
13123       real(kind=8) :: r,gamm
13124       if(r.lt.r_cut-rlamb) then
13125         sscale_grad=0.0d0
13126       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13127         gamm=(r-(r_cut-rlamb))/rlamb
13128         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
13129       else
13130         sscale_grad=0d0
13131       endif
13132       return
13133       end function sscale_grad
13134
13135 !!!!!!!!!! PBCSCALE
13136       real(kind=8) function sscale_ele(r)
13137 !      include "COMMON.SPLITELE"
13138       real(kind=8) :: r,gamm
13139       if(r.lt.r_cut_ele-rlamb_ele) then
13140         sscale_ele=1.0d0
13141       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13142         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13143         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13144       else
13145         sscale_ele=0d0
13146       endif
13147       return
13148       end function sscale_ele
13149
13150       real(kind=8)  function sscagrad_ele(r)
13151       real(kind=8) :: r,gamm
13152 !      include "COMMON.SPLITELE"
13153       if(r.lt.r_cut_ele-rlamb_ele) then
13154         sscagrad_ele=0.0d0
13155       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13156         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13157         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
13158       else
13159         sscagrad_ele=0.0d0
13160       endif
13161       return
13162       end function sscagrad_ele
13163       real(kind=8) function sscalelip(r)
13164       real(kind=8) r,gamm
13165         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
13166       return
13167       end function sscalelip
13168 !C-----------------------------------------------------------------------
13169       real(kind=8) function sscagradlip(r)
13170       real(kind=8) r,gamm
13171         sscagradlip=r*(6.0d0*r-6.0d0)
13172       return
13173       end function sscagradlip
13174
13175 !!!!!!!!!!!!!!!
13176 !-----------------------------------------------------------------------------
13177       subroutine elj_long(evdw)
13178 !
13179 ! This subroutine calculates the interaction energy of nonbonded side chains
13180 ! assuming the LJ potential of interaction.
13181 !
13182 !      implicit real*8 (a-h,o-z)
13183 !      include 'DIMENSIONS'
13184 !      include 'COMMON.GEO'
13185 !      include 'COMMON.VAR'
13186 !      include 'COMMON.LOCAL'
13187 !      include 'COMMON.CHAIN'
13188 !      include 'COMMON.DERIV'
13189 !      include 'COMMON.INTERACT'
13190 !      include 'COMMON.TORSION'
13191 !      include 'COMMON.SBRIDGE'
13192 !      include 'COMMON.NAMES'
13193 !      include 'COMMON.IOUNITS'
13194 !      include 'COMMON.CONTACTS'
13195       real(kind=8),parameter :: accur=1.0d-10
13196       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13197 !el local variables
13198       integer :: i,iint,j,k,itypi,itypi1,itypj
13199       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13200       real(kind=8) :: e1,e2,evdwij,evdw,sslipi,ssgradlipi,&
13201                       sslipj,ssgradlipj,aa,bb
13202 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13203       evdw=0.0D0
13204       do i=iatsc_s,iatsc_e
13205         itypi=itype(i,1)
13206         if (itypi.eq.ntyp1) cycle
13207         itypi1=itype(i+1,1)
13208         xi=c(1,nres+i)
13209         yi=c(2,nres+i)
13210         zi=c(3,nres+i)
13211         call to_box(xi,yi,zi)
13212         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13213 !
13214 ! Calculate SC interaction energy.
13215 !
13216         do iint=1,nint_gr(i)
13217 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13218 !d   &                  'iend=',iend(i,iint)
13219           do j=istart(i,iint),iend(i,iint)
13220             itypj=itype(j,1)
13221             if (itypj.eq.ntyp1) cycle
13222             xj=c(1,nres+j)-xi
13223             yj=c(2,nres+j)-yi
13224             zj=c(3,nres+j)-zi
13225             call to_box(xj,yj,zj)
13226             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13227             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13228              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13229             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13230              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13231             xj=boxshift(xj-xi,boxxsize)
13232             yj=boxshift(yj-yi,boxysize)
13233             zj=boxshift(zj-zi,boxzsize)
13234             rij=xj*xj+yj*yj+zj*zj
13235             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13236             if (sss.lt.1.0d0) then
13237               rrij=1.0D0/rij
13238               eps0ij=eps(itypi,itypj)
13239               fac=rrij**expon2
13240               e1=fac*fac*aa_aq(itypi,itypj)
13241               e2=fac*bb_aq(itypi,itypj)
13242               evdwij=e1+e2
13243               evdw=evdw+(1.0d0-sss)*evdwij
13244 !
13245 ! Calculate the components of the gradient in DC and X
13246 !
13247               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
13248               gg(1)=xj*fac
13249               gg(2)=yj*fac
13250               gg(3)=zj*fac
13251               do k=1,3
13252                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13253                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13254                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13255                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13256               enddo
13257             endif
13258           enddo      ! j
13259         enddo        ! iint
13260       enddo          ! i
13261       do i=1,nct
13262         do j=1,3
13263           gvdwc(j,i)=expon*gvdwc(j,i)
13264           gvdwx(j,i)=expon*gvdwx(j,i)
13265         enddo
13266       enddo
13267 !******************************************************************************
13268 !
13269 !                              N O T E !!!
13270 !
13271 ! To save time, the factor of EXPON has been extracted from ALL components
13272 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13273 ! use!
13274 !
13275 !******************************************************************************
13276       return
13277       end subroutine elj_long
13278 !-----------------------------------------------------------------------------
13279       subroutine elj_short(evdw)
13280 !
13281 ! This subroutine calculates the interaction energy of nonbonded side chains
13282 ! assuming the LJ potential of interaction.
13283 !
13284 !      implicit real*8 (a-h,o-z)
13285 !      include 'DIMENSIONS'
13286 !      include 'COMMON.GEO'
13287 !      include 'COMMON.VAR'
13288 !      include 'COMMON.LOCAL'
13289 !      include 'COMMON.CHAIN'
13290 !      include 'COMMON.DERIV'
13291 !      include 'COMMON.INTERACT'
13292 !      include 'COMMON.TORSION'
13293 !      include 'COMMON.SBRIDGE'
13294 !      include 'COMMON.NAMES'
13295 !      include 'COMMON.IOUNITS'
13296 !      include 'COMMON.CONTACTS'
13297       real(kind=8),parameter :: accur=1.0d-10
13298       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13299 !el local variables
13300       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
13301       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13302       real(kind=8) :: e1,e2,evdwij,evdw,sslipi,ssgradlipi,&
13303                       sslipj,ssgradlipj
13304 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13305       evdw=0.0D0
13306       do i=iatsc_s,iatsc_e
13307         itypi=itype(i,1)
13308         if (itypi.eq.ntyp1) cycle
13309         itypi1=itype(i+1,1)
13310         xi=c(1,nres+i)
13311         yi=c(2,nres+i)
13312         zi=c(3,nres+i)
13313         call to_box(xi,yi,zi)
13314         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13315 ! Change 12/1/95
13316         num_conti=0
13317 !
13318 ! Calculate SC interaction energy.
13319 !
13320         do iint=1,nint_gr(i)
13321 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13322 !d   &                  'iend=',iend(i,iint)
13323           do j=istart(i,iint),iend(i,iint)
13324             itypj=itype(j,1)
13325             if (itypj.eq.ntyp1) cycle
13326             xj=c(1,nres+j)-xi
13327             yj=c(2,nres+j)-yi
13328             zj=c(3,nres+j)-zi
13329 ! Change 12/1/95 to calculate four-body interactions
13330             rij=xj*xj+yj*yj+zj*zj
13331             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13332             if (sss.gt.0.0d0) then
13333               rrij=1.0D0/rij
13334               eps0ij=eps(itypi,itypj)
13335               fac=rrij**expon2
13336               e1=fac*fac*aa_aq(itypi,itypj)
13337               e2=fac*bb_aq(itypi,itypj)
13338               evdwij=e1+e2
13339               evdw=evdw+sss*evdwij
13340 !
13341 ! Calculate the components of the gradient in DC and X
13342 !
13343               fac=-rrij*(e1+evdwij)*sss
13344               gg(1)=xj*fac
13345               gg(2)=yj*fac
13346               gg(3)=zj*fac
13347               do k=1,3
13348                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13349                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13350                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13351                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13352               enddo
13353             endif
13354           enddo      ! j
13355         enddo        ! iint
13356       enddo          ! i
13357       do i=1,nct
13358         do j=1,3
13359           gvdwc(j,i)=expon*gvdwc(j,i)
13360           gvdwx(j,i)=expon*gvdwx(j,i)
13361         enddo
13362       enddo
13363 !******************************************************************************
13364 !
13365 !                              N O T E !!!
13366 !
13367 ! To save time, the factor of EXPON has been extracted from ALL components
13368 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13369 ! use!
13370 !
13371 !******************************************************************************
13372       return
13373       end subroutine elj_short
13374 !-----------------------------------------------------------------------------
13375       subroutine eljk_long(evdw)
13376 !
13377 ! This subroutine calculates the interaction energy of nonbonded side chains
13378 ! assuming the LJK potential of interaction.
13379 !
13380 !      implicit real*8 (a-h,o-z)
13381 !      include 'DIMENSIONS'
13382 !      include 'COMMON.GEO'
13383 !      include 'COMMON.VAR'
13384 !      include 'COMMON.LOCAL'
13385 !      include 'COMMON.CHAIN'
13386 !      include 'COMMON.DERIV'
13387 !      include 'COMMON.INTERACT'
13388 !      include 'COMMON.IOUNITS'
13389 !      include 'COMMON.NAMES'
13390       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13391       logical :: scheck
13392 !el local variables
13393       integer :: i,iint,j,k,itypi,itypi1,itypj
13394       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13395                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
13396 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13397       evdw=0.0D0
13398       do i=iatsc_s,iatsc_e
13399         itypi=itype(i,1)
13400         if (itypi.eq.ntyp1) cycle
13401         itypi1=itype(i+1,1)
13402         xi=c(1,nres+i)
13403         yi=c(2,nres+i)
13404         zi=c(3,nres+i)
13405           call to_box(xi,yi,zi)
13406
13407 !
13408 ! Calculate SC interaction energy.
13409 !
13410         do iint=1,nint_gr(i)
13411           do j=istart(i,iint),iend(i,iint)
13412             itypj=itype(j,1)
13413             if (itypj.eq.ntyp1) cycle
13414             xj=c(1,nres+j)-xi
13415             yj=c(2,nres+j)-yi
13416             zj=c(3,nres+j)-zi
13417           call to_box(xj,yj,zj)
13418       xj=boxshift(xj-xi,boxxsize)
13419       yj=boxshift(yj-yi,boxysize)
13420       zj=boxshift(zj-zi,boxzsize)
13421
13422             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13423             fac_augm=rrij**expon
13424             e_augm=augm(itypi,itypj)*fac_augm
13425             r_inv_ij=dsqrt(rrij)
13426             rij=1.0D0/r_inv_ij
13427             sss=sscale(rij/sigma(itypi,itypj))
13428             if (sss.lt.1.0d0) then
13429               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13430               fac=r_shift_inv**expon
13431               e1=fac*fac*aa_aq(itypi,itypj)
13432               e2=fac*bb_aq(itypi,itypj)
13433               evdwij=e_augm+e1+e2
13434 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13435 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13436 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13437 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13438 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13439 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13440 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13441               evdw=evdw+(1.0d0-sss)*evdwij
13442 !
13443 ! Calculate the components of the gradient in DC and X
13444 !
13445               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13446               fac=fac*(1.0d0-sss)
13447               gg(1)=xj*fac
13448               gg(2)=yj*fac
13449               gg(3)=zj*fac
13450               do k=1,3
13451                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13452                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13453                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13454                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13455               enddo
13456             endif
13457           enddo      ! j
13458         enddo        ! iint
13459       enddo          ! i
13460       do i=1,nct
13461         do j=1,3
13462           gvdwc(j,i)=expon*gvdwc(j,i)
13463           gvdwx(j,i)=expon*gvdwx(j,i)
13464         enddo
13465       enddo
13466       return
13467       end subroutine eljk_long
13468 !-----------------------------------------------------------------------------
13469       subroutine eljk_short(evdw)
13470 !
13471 ! This subroutine calculates the interaction energy of nonbonded side chains
13472 ! assuming the LJK potential of interaction.
13473 !
13474 !      implicit real*8 (a-h,o-z)
13475 !      include 'DIMENSIONS'
13476 !      include 'COMMON.GEO'
13477 !      include 'COMMON.VAR'
13478 !      include 'COMMON.LOCAL'
13479 !      include 'COMMON.CHAIN'
13480 !      include 'COMMON.DERIV'
13481 !      include 'COMMON.INTERACT'
13482 !      include 'COMMON.IOUNITS'
13483 !      include 'COMMON.NAMES'
13484       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13485       logical :: scheck
13486 !el local variables
13487       integer :: i,iint,j,k,itypi,itypi1,itypj
13488       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
13489                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij,&
13490                    sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
13491 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
13492       evdw=0.0D0
13493       do i=iatsc_s,iatsc_e
13494         itypi=itype(i,1)
13495         if (itypi.eq.ntyp1) cycle
13496         itypi1=itype(i+1,1)
13497         xi=c(1,nres+i)
13498         yi=c(2,nres+i)
13499         zi=c(3,nres+i)
13500         call to_box(xi,yi,zi)
13501         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13502 !
13503 ! Calculate SC interaction energy.
13504 !
13505         do iint=1,nint_gr(i)
13506           do j=istart(i,iint),iend(i,iint)
13507             itypj=itype(j,1)
13508             if (itypj.eq.ntyp1) cycle
13509             xj=c(1,nres+j)-xi
13510             yj=c(2,nres+j)-yi
13511             zj=c(3,nres+j)-zi
13512             call to_box(xj,yj,zj)
13513             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13514             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13515              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13516             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13517              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13518             xj=boxshift(xj-xi,boxxsize)
13519             yj=boxshift(yj-yi,boxysize)
13520             zj=boxshift(zj-zi,boxzsize)
13521             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13522             fac_augm=rrij**expon
13523             e_augm=augm(itypi,itypj)*fac_augm
13524             r_inv_ij=dsqrt(rrij)
13525             rij=1.0D0/r_inv_ij
13526             sss=sscale(rij/sigma(itypi,itypj))
13527             if (sss.gt.0.0d0) then
13528               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13529               fac=r_shift_inv**expon
13530               e1=fac*fac*aa_aq(itypi,itypj)
13531               e2=fac*bb_aq(itypi,itypj)
13532               evdwij=e_augm+e1+e2
13533 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13534 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13535 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13536 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13537 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13538 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13539 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13540               evdw=evdw+sss*evdwij
13541 !
13542 ! Calculate the components of the gradient in DC and X
13543 !
13544               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13545               fac=fac*sss
13546               gg(1)=xj*fac
13547               gg(2)=yj*fac
13548               gg(3)=zj*fac
13549               do k=1,3
13550                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13551                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13552                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13553                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13554               enddo
13555             endif
13556           enddo      ! j
13557         enddo        ! iint
13558       enddo          ! i
13559       do i=1,nct
13560         do j=1,3
13561           gvdwc(j,i)=expon*gvdwc(j,i)
13562           gvdwx(j,i)=expon*gvdwx(j,i)
13563         enddo
13564       enddo
13565       return
13566       end subroutine eljk_short
13567 !-----------------------------------------------------------------------------
13568        subroutine ebp_long(evdw)
13569 ! This subroutine calculates the interaction energy of nonbonded side chains
13570 ! assuming the Berne-Pechukas potential of interaction.
13571 !
13572        use calc_data
13573 !      implicit real*8 (a-h,o-z)
13574 !      include 'DIMENSIONS'
13575 !      include 'COMMON.GEO'
13576 !      include 'COMMON.VAR'
13577 !      include 'COMMON.LOCAL'
13578 !      include 'COMMON.CHAIN'
13579 !      include 'COMMON.DERIV'
13580 !      include 'COMMON.NAMES'
13581 !      include 'COMMON.INTERACT'
13582 !      include 'COMMON.IOUNITS'
13583 !      include 'COMMON.CALC'
13584        use comm_srutu
13585 !el      integer :: icall
13586 !el      common /srutu/ icall
13587 !     double precision rrsave(maxdim)
13588         logical :: lprn
13589 !el local variables
13590         integer :: iint,itypi,itypi1,itypj
13591         real(kind=8) :: rrij,xi,yi,zi,fac,sslipi,ssgradlipi,&
13592                         sslipj,ssgradlipj,aa,bb
13593         real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
13594         evdw=0.0D0
13595 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13596         evdw=0.0D0
13597 !     if (icall.eq.0) then
13598 !       lprn=.true.
13599 !     else
13600       lprn=.false.
13601 !     endif
13602 !el      ind=0
13603       do i=iatsc_s,iatsc_e
13604       itypi=itype(i,1)
13605       if (itypi.eq.ntyp1) cycle
13606       itypi1=itype(i+1,1)
13607       xi=c(1,nres+i)
13608       yi=c(2,nres+i)
13609       zi=c(3,nres+i)
13610         call to_box(xi,yi,zi)
13611         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13612       dxi=dc_norm(1,nres+i)
13613       dyi=dc_norm(2,nres+i)
13614       dzi=dc_norm(3,nres+i)
13615 !        dsci_inv=dsc_inv(itypi)
13616       dsci_inv=vbld_inv(i+nres)
13617 !
13618 ! Calculate SC interaction energy.
13619 !
13620       do iint=1,nint_gr(i)
13621       do j=istart(i,iint),iend(i,iint)
13622 !el            ind=ind+1
13623       itypj=itype(j,1)
13624       if (itypj.eq.ntyp1) cycle
13625 !            dscj_inv=dsc_inv(itypj)
13626       dscj_inv=vbld_inv(j+nres)
13627 chi1=chi(itypi,itypj)
13628 chi2=chi(itypj,itypi)
13629 chi12=chi1*chi2
13630 chip1=chip(itypi)
13631       alf1=alp(itypi)
13632       alf2=alp(itypj)
13633       alf12=0.5D0*(alf1+alf2)
13634         xj=c(1,nres+j)-xi
13635         yj=c(2,nres+j)-yi
13636         zj=c(3,nres+j)-zi
13637             call to_box(xj,yj,zj)
13638             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13639             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13640              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13641             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13642              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13643             xj=boxshift(xj-xi,boxxsize)
13644             yj=boxshift(yj-yi,boxysize)
13645             zj=boxshift(zj-zi,boxzsize)
13646         dxj=dc_norm(1,nres+j)
13647         dyj=dc_norm(2,nres+j)
13648         dzj=dc_norm(3,nres+j)
13649         rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13650         rij=dsqrt(rrij)
13651       sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13652
13653         if (sss.lt.1.0d0) then
13654
13655         ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13656         call sc_angular
13657         ! Calculate whole angle-dependent part of epsilon and contributions
13658         ! to its derivatives
13659         fac=(rrij*sigsq)**expon2
13660         e1=fac*fac*aa_aq(itypi,itypj)
13661         e2=fac*bb_aq(itypi,itypj)
13662       evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13663         eps2der=evdwij*eps3rt
13664         eps3der=evdwij*eps2rt
13665         evdwij=evdwij*eps2rt*eps3rt
13666       evdw=evdw+evdwij*(1.0d0-sss)
13667         if (lprn) then
13668         sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13669       epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13670         !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13671         !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13672         !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13673         !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13674         !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13675         !d     &          evdwij
13676         endif
13677         ! Calculate gradient components.
13678         e1=e1*eps1*eps2rt**2*eps3rt**2
13679       fac=-expon*(e1+evdwij)
13680         sigder=fac/sigsq
13681         fac=rrij*fac
13682         ! Calculate radial part of the gradient
13683         gg(1)=xj*fac
13684         gg(2)=yj*fac
13685         gg(3)=zj*fac
13686         ! Calculate the angular part of the gradient and sum add the contributions
13687         ! to the appropriate components of the Cartesian gradient.
13688       call sc_grad_scale(1.0d0-sss)
13689         endif
13690         enddo      ! j
13691         enddo        ! iint
13692         enddo          ! i
13693         !     stop
13694         return
13695         end subroutine ebp_long
13696         !-----------------------------------------------------------------------------
13697       subroutine ebp_short(evdw)
13698         !
13699         ! This subroutine calculates the interaction energy of nonbonded side chains
13700         ! assuming the Berne-Pechukas potential of interaction.
13701         !
13702         use calc_data
13703 !      implicit real*8 (a-h,o-z)
13704         !      include 'DIMENSIONS'
13705         !      include 'COMMON.GEO'
13706         !      include 'COMMON.VAR'
13707         !      include 'COMMON.LOCAL'
13708         !      include 'COMMON.CHAIN'
13709         !      include 'COMMON.DERIV'
13710         !      include 'COMMON.NAMES'
13711         !      include 'COMMON.INTERACT'
13712         !      include 'COMMON.IOUNITS'
13713         !      include 'COMMON.CALC'
13714         use comm_srutu
13715         !el      integer :: icall
13716         !el      common /srutu/ icall
13717 !     double precision rrsave(maxdim)
13718         logical :: lprn
13719         !el local variables
13720         integer :: iint,itypi,itypi1,itypj
13721         real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
13722         real(kind=8) :: sss,e1,e2,evdw,aa,bb, &
13723         sslipi,ssgradlipi,sslipj,ssgradlipj
13724         evdw=0.0D0
13725         !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13726         evdw=0.0D0
13727         !     if (icall.eq.0) then
13728         !       lprn=.true.
13729         !     else
13730         lprn=.false.
13731         !     endif
13732         !el      ind=0
13733         do i=iatsc_s,iatsc_e
13734       itypi=itype(i,1)
13735         if (itypi.eq.ntyp1) cycle
13736         itypi1=itype(i+1,1)
13737         xi=c(1,nres+i)
13738         yi=c(2,nres+i)
13739         zi=c(3,nres+i)
13740         call to_box(xi,yi,zi)
13741       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13742
13743         dxi=dc_norm(1,nres+i)
13744         dyi=dc_norm(2,nres+i)
13745         dzi=dc_norm(3,nres+i)
13746         !        dsci_inv=dsc_inv(itypi)
13747       dsci_inv=vbld_inv(i+nres)
13748         !
13749         ! Calculate SC interaction energy.
13750         !
13751         do iint=1,nint_gr(i)
13752       do j=istart(i,iint),iend(i,iint)
13753         !el            ind=ind+1
13754       itypj=itype(j,1)
13755         if (itypj.eq.ntyp1) cycle
13756         !            dscj_inv=dsc_inv(itypj)
13757         dscj_inv=vbld_inv(j+nres)
13758         chi1=chi(itypi,itypj)
13759       chi2=chi(itypj,itypi)
13760         chi12=chi1*chi2
13761         chip1=chip(itypi)
13762       chip2=chip(itypj)
13763         chip12=chip1*chip2
13764         alf1=alp(itypi)
13765         alf2=alp(itypj)
13766       alf12=0.5D0*(alf1+alf2)
13767         xj=c(1,nres+j)-xi
13768         yj=c(2,nres+j)-yi
13769         zj=c(3,nres+j)-zi
13770         call to_box(xj,yj,zj)
13771       call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13772         aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13773         +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13774         bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13775              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13776             xj=boxshift(xj-xi,boxxsize)
13777             yj=boxshift(yj-yi,boxysize)
13778             zj=boxshift(zj-zi,boxzsize)
13779             dxj=dc_norm(1,nres+j)
13780             dyj=dc_norm(2,nres+j)
13781             dzj=dc_norm(3,nres+j)
13782             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13783             rij=dsqrt(rrij)
13784             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13785
13786             if (sss.gt.0.0d0) then
13787
13788 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13789               call sc_angular
13790 ! Calculate whole angle-dependent part of epsilon and contributions
13791 ! to its derivatives
13792               fac=(rrij*sigsq)**expon2
13793               e1=fac*fac*aa_aq(itypi,itypj)
13794               e2=fac*bb_aq(itypi,itypj)
13795               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13796               eps2der=evdwij*eps3rt
13797               eps3der=evdwij*eps2rt
13798               evdwij=evdwij*eps2rt*eps3rt
13799               evdw=evdw+evdwij*sss
13800               if (lprn) then
13801               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13802               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13803 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13804 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13805 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13806 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13807 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13808 !d     &          evdwij
13809               endif
13810 ! Calculate gradient components.
13811               e1=e1*eps1*eps2rt**2*eps3rt**2
13812               fac=-expon*(e1+evdwij)
13813               sigder=fac/sigsq
13814               fac=rrij*fac
13815 ! Calculate radial part of the gradient
13816               gg(1)=xj*fac
13817               gg(2)=yj*fac
13818               gg(3)=zj*fac
13819 ! Calculate the angular part of the gradient and sum add the contributions
13820 ! to the appropriate components of the Cartesian gradient.
13821               call sc_grad_scale(sss)
13822             endif
13823           enddo      ! j
13824         enddo        ! iint
13825       enddo          ! i
13826 !     stop
13827       return
13828       end subroutine ebp_short
13829 !-----------------------------------------------------------------------------
13830       subroutine egb_long(evdw)
13831 !
13832 ! This subroutine calculates the interaction energy of nonbonded side chains
13833 ! assuming the Gay-Berne potential of interaction.
13834 !
13835       use calc_data
13836 !      implicit real*8 (a-h,o-z)
13837 !      include 'DIMENSIONS'
13838 !      include 'COMMON.GEO'
13839 !      include 'COMMON.VAR'
13840 !      include 'COMMON.LOCAL'
13841 !      include 'COMMON.CHAIN'
13842 !      include 'COMMON.DERIV'
13843 !      include 'COMMON.NAMES'
13844 !      include 'COMMON.INTERACT'
13845 !      include 'COMMON.IOUNITS'
13846 !      include 'COMMON.CALC'
13847 !      include 'COMMON.CONTROL'
13848       logical :: lprn
13849 !el local variables
13850       integer :: iint,itypi,itypi1,itypj,subchap
13851       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13852       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13853       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13854                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13855                     ssgradlipi,ssgradlipj
13856
13857
13858       evdw=0.0D0
13859 !cccc      energy_dec=.false.
13860 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13861       evdw=0.0D0
13862       lprn=.false.
13863 !     if (icall.eq.0) lprn=.false.
13864 !el      ind=0
13865       do i=iatsc_s,iatsc_e
13866         itypi=itype(i,1)
13867         if (itypi.eq.ntyp1) cycle
13868         itypi1=itype(i+1,1)
13869         xi=c(1,nres+i)
13870         yi=c(2,nres+i)
13871         zi=c(3,nres+i)
13872         call to_box(xi,yi,zi)
13873         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13874         dxi=dc_norm(1,nres+i)
13875         dyi=dc_norm(2,nres+i)
13876         dzi=dc_norm(3,nres+i)
13877 !        dsci_inv=dsc_inv(itypi)
13878         dsci_inv=vbld_inv(i+nres)
13879 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13880 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13881 !
13882 ! Calculate SC interaction energy.
13883 !
13884         do iint=1,nint_gr(i)
13885           do j=istart(i,iint),iend(i,iint)
13886             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13887 !              call dyn_ssbond_ene(i,j,evdwij)
13888 !              evdw=evdw+evdwij
13889 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13890 !                              'evdw',i,j,evdwij,' ss'
13891 !              if (energy_dec) write (iout,*) &
13892 !                              'evdw',i,j,evdwij,' ss'
13893 !             do k=j+1,iend(i,iint)
13894 !C search over all next residues
13895 !              if (dyn_ss_mask(k)) then
13896 !C check if they are cysteins
13897 !C              write(iout,*) 'k=',k
13898
13899 !c              write(iout,*) "PRZED TRI", evdwij
13900 !               evdwij_przed_tri=evdwij
13901 !              call triple_ssbond_ene(i,j,k,evdwij)
13902 !c               if(evdwij_przed_tri.ne.evdwij) then
13903 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13904 !c               endif
13905
13906 !c              write(iout,*) "PO TRI", evdwij
13907 !C call the energy function that removes the artifical triple disulfide
13908 !C bond the soubroutine is located in ssMD.F
13909 !              evdw=evdw+evdwij
13910               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13911                             'evdw',i,j,evdwij,'tss'
13912 !              endif!dyn_ss_mask(k)
13913 !             enddo! k
13914
13915             ELSE
13916 !el            ind=ind+1
13917             itypj=itype(j,1)
13918             if (itypj.eq.ntyp1) cycle
13919 !            dscj_inv=dsc_inv(itypj)
13920             dscj_inv=vbld_inv(j+nres)
13921 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13922 !     &       1.0d0/vbld(j+nres)
13923 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13924             sig0ij=sigma(itypi,itypj)
13925             chi1=chi(itypi,itypj)
13926             chi2=chi(itypj,itypi)
13927             chi12=chi1*chi2
13928             chip1=chip(itypi)
13929             chip2=chip(itypj)
13930             chip12=chip1*chip2
13931             alf1=alp(itypi)
13932             alf2=alp(itypj)
13933             alf12=0.5D0*(alf1+alf2)
13934             xj=c(1,nres+j)
13935             yj=c(2,nres+j)
13936             zj=c(3,nres+j)
13937 ! Searching for nearest neighbour
13938             call to_box(xj,yj,zj)
13939             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13940             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13941              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13942             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13943              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13944             xj=boxshift(xj-xi,boxxsize)
13945             yj=boxshift(yj-yi,boxysize)
13946             zj=boxshift(zj-zi,boxzsize)
13947             dxj=dc_norm(1,nres+j)
13948             dyj=dc_norm(2,nres+j)
13949             dzj=dc_norm(3,nres+j)
13950             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13951             rij=dsqrt(rrij)
13952             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13953             sss_ele_cut=sscale_ele(1.0d0/(rij))
13954             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
13955             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13956             if (sss_ele_cut.le.0.0) cycle
13957             if (sss.lt.1.0d0) then
13958
13959 ! Calculate angle-dependent terms of energy and contributions to their
13960 ! derivatives.
13961               call sc_angular
13962               sigsq=1.0D0/sigsq
13963               sig=sig0ij*dsqrt(sigsq)
13964               rij_shift=1.0D0/rij-sig+sig0ij
13965 ! for diagnostics; uncomment
13966 !              rij_shift=1.2*sig0ij
13967 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13968               if (rij_shift.le.0.0D0) then
13969                 evdw=1.0D20
13970 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13971 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13972 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13973                 return
13974               endif
13975               sigder=-sig*sigsq
13976 !---------------------------------------------------------------
13977               rij_shift=1.0D0/rij_shift
13978               fac=rij_shift**expon
13979               e1=fac*fac*aa
13980               e2=fac*bb
13981               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13982               eps2der=evdwij*eps3rt
13983               eps3der=evdwij*eps2rt
13984 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13985 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13986               evdwij=evdwij*eps2rt*eps3rt
13987               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
13988               if (lprn) then
13989               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13990               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13991               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13992                 restyp(itypi,1),i,restyp(itypj,1),j,&
13993                 epsi,sigm,chi1,chi2,chip1,chip2,&
13994                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13995                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13996                 evdwij
13997               endif
13998
13999               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14000                               'evdw',i,j,evdwij
14001 !              if (energy_dec) write (iout,*) &
14002 !                              'evdw',i,j,evdwij,"egb_long"
14003
14004 ! Calculate gradient components.
14005               e1=e1*eps1*eps2rt**2*eps3rt**2
14006               fac=-expon*(e1+evdwij)*rij_shift
14007               sigder=fac*sigder
14008               fac=rij*fac
14009               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14010               *rij-sss_grad/(1.0-sss)*rij  &
14011             /sigmaii(itypi,itypj))
14012 !              fac=0.0d0
14013 ! Calculate the radial part of the gradient
14014               gg(1)=xj*fac
14015               gg(2)=yj*fac
14016               gg(3)=zj*fac
14017 ! Calculate angular part of the gradient.
14018               call sc_grad_scale(1.0d0-sss)
14019             ENDIF    !mask_dyn_ss
14020             endif
14021           enddo      ! j
14022         enddo        ! iint
14023       enddo          ! i
14024 !      write (iout,*) "Number of loop steps in EGB:",ind
14025 !ccc      energy_dec=.false.
14026       return
14027       end subroutine egb_long
14028 !-----------------------------------------------------------------------------
14029       subroutine egb_short(evdw)
14030 !
14031 ! This subroutine calculates the interaction energy of nonbonded side chains
14032 ! assuming the Gay-Berne potential of interaction.
14033 !
14034       use calc_data
14035 !      implicit real*8 (a-h,o-z)
14036 !      include 'DIMENSIONS'
14037 !      include 'COMMON.GEO'
14038 !      include 'COMMON.VAR'
14039 !      include 'COMMON.LOCAL'
14040 !      include 'COMMON.CHAIN'
14041 !      include 'COMMON.DERIV'
14042 !      include 'COMMON.NAMES'
14043 !      include 'COMMON.INTERACT'
14044 !      include 'COMMON.IOUNITS'
14045 !      include 'COMMON.CALC'
14046 !      include 'COMMON.CONTROL'
14047       logical :: lprn
14048 !el local variables
14049       integer :: iint,itypi,itypi1,itypj,subchap
14050       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
14051       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
14052       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14053                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
14054                     ssgradlipi,ssgradlipj
14055       evdw=0.0D0
14056 !cccc      energy_dec=.false.
14057 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14058       evdw=0.0D0
14059       lprn=.false.
14060 !     if (icall.eq.0) lprn=.false.
14061 !el      ind=0
14062       do i=iatsc_s,iatsc_e
14063         itypi=itype(i,1)
14064         if (itypi.eq.ntyp1) cycle
14065         itypi1=itype(i+1,1)
14066         xi=c(1,nres+i)
14067         yi=c(2,nres+i)
14068         zi=c(3,nres+i)
14069         call to_box(xi,yi,zi)
14070         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14071
14072         dxi=dc_norm(1,nres+i)
14073         dyi=dc_norm(2,nres+i)
14074         dzi=dc_norm(3,nres+i)
14075 !        dsci_inv=dsc_inv(itypi)
14076         dsci_inv=vbld_inv(i+nres)
14077
14078         dxi=dc_norm(1,nres+i)
14079         dyi=dc_norm(2,nres+i)
14080         dzi=dc_norm(3,nres+i)
14081 !        dsci_inv=dsc_inv(itypi)
14082         dsci_inv=vbld_inv(i+nres)
14083         do iint=1,nint_gr(i)
14084           do j=istart(i,iint),iend(i,iint)
14085             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
14086               call dyn_ssbond_ene(i,j,evdwij)
14087               evdw=evdw+evdwij
14088               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14089                               'evdw',i,j,evdwij,' ss'
14090              do k=j+1,iend(i,iint)
14091 !C search over all next residues
14092               if (dyn_ss_mask(k)) then
14093 !C check if they are cysteins
14094 !C              write(iout,*) 'k=',k
14095
14096 !c              write(iout,*) "PRZED TRI", evdwij
14097 !               evdwij_przed_tri=evdwij
14098               call triple_ssbond_ene(i,j,k,evdwij)
14099 !c               if(evdwij_przed_tri.ne.evdwij) then
14100 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
14101 !c               endif
14102
14103 !c              write(iout,*) "PO TRI", evdwij
14104 !C call the energy function that removes the artifical triple disulfide
14105 !C bond the soubroutine is located in ssMD.F
14106               evdw=evdw+evdwij
14107               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14108                             'evdw',i,j,evdwij,'tss'
14109               endif!dyn_ss_mask(k)
14110              enddo! k
14111             ELSE
14112
14113 !          typj=itype(j,1)
14114             if (itypj.eq.ntyp1) cycle
14115 !            dscj_inv=dsc_inv(itypj)
14116             dscj_inv=vbld_inv(j+nres)
14117             dscj_inv=dsc_inv(itypj)
14118 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
14119 !     &       1.0d0/vbld(j+nres)
14120 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
14121             sig0ij=sigma(itypi,itypj)
14122             chi1=chi(itypi,itypj)
14123             chi2=chi(itypj,itypi)
14124             chi12=chi1*chi2
14125             chip1=chip(itypi)
14126             chip2=chip(itypj)
14127             chip12=chip1*chip2
14128             alf1=alp(itypi)
14129             alf2=alp(itypj)
14130             alf12=0.5D0*(alf1+alf2)
14131 !            xj=c(1,nres+j)-xi
14132 !            yj=c(2,nres+j)-yi
14133 !            zj=c(3,nres+j)-zi
14134             xj=c(1,nres+j)
14135             yj=c(2,nres+j)
14136             zj=c(3,nres+j)
14137 ! Searching for nearest neighbour
14138             call to_box(xj,yj,zj)
14139             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14140             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14141              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14142             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14143              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14144             xj=boxshift(xj-xi,boxxsize)
14145             yj=boxshift(yj-yi,boxysize)
14146             zj=boxshift(zj-zi,boxzsize)
14147             dxj=dc_norm(1,nres+j)
14148             dyj=dc_norm(2,nres+j)
14149             dzj=dc_norm(3,nres+j)
14150             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14151             rij=dsqrt(rrij)
14152             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14153             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14154             sss_ele_cut=sscale_ele(1.0d0/(rij))
14155             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
14156             if (sss_ele_cut.le.0.0) cycle
14157
14158             if (sss.gt.0.0d0) then
14159
14160 ! Calculate angle-dependent terms of energy and contributions to their
14161 ! derivatives.
14162               call sc_angular
14163               sigsq=1.0D0/sigsq
14164               sig=sig0ij*dsqrt(sigsq)
14165               rij_shift=1.0D0/rij-sig+sig0ij
14166 ! for diagnostics; uncomment
14167 !              rij_shift=1.2*sig0ij
14168 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14169               if (rij_shift.le.0.0D0) then
14170                 evdw=1.0D20
14171 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14172 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14173 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14174                 return
14175               endif
14176               sigder=-sig*sigsq
14177 !---------------------------------------------------------------
14178               rij_shift=1.0D0/rij_shift
14179               fac=rij_shift**expon
14180               e1=fac*fac*aa
14181               e2=fac*bb
14182               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14183               eps2der=evdwij*eps3rt
14184               eps3der=evdwij*eps2rt
14185 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14186 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14187               evdwij=evdwij*eps2rt*eps3rt
14188               evdw=evdw+evdwij*sss*sss_ele_cut
14189               if (lprn) then
14190               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14191               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14192               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14193                 restyp(itypi,1),i,restyp(itypj,1),j,&
14194                 epsi,sigm,chi1,chi2,chip1,chip2,&
14195                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14196                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14197                 evdwij
14198               endif
14199
14200               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14201                               'evdw',i,j,evdwij
14202 !              if (energy_dec) write (iout,*) &
14203 !                              'evdw',i,j,evdwij,"egb_short"
14204
14205 ! Calculate gradient components.
14206               e1=e1*eps1*eps2rt**2*eps3rt**2
14207               fac=-expon*(e1+evdwij)*rij_shift
14208               sigder=fac*sigder
14209               fac=rij*fac
14210               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14211             *rij+sss_grad/sss*rij  &
14212             /sigmaii(itypi,itypj))
14213
14214 !              fac=0.0d0
14215 ! Calculate the radial part of the gradient
14216               gg(1)=xj*fac
14217               gg(2)=yj*fac
14218               gg(3)=zj*fac
14219 ! Calculate angular part of the gradient.
14220               call sc_grad_scale(sss)
14221             endif
14222           ENDIF !mask_dyn_ss
14223           enddo      ! j
14224         enddo        ! iint
14225       enddo          ! i
14226 !      write (iout,*) "Number of loop steps in EGB:",ind
14227 !ccc      energy_dec=.false.
14228       return
14229       end subroutine egb_short
14230 !-----------------------------------------------------------------------------
14231       subroutine egbv_long(evdw)
14232 !
14233 ! This subroutine calculates the interaction energy of nonbonded side chains
14234 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14235 !
14236       use calc_data
14237 !      implicit real*8 (a-h,o-z)
14238 !      include 'DIMENSIONS'
14239 !      include 'COMMON.GEO'
14240 !      include 'COMMON.VAR'
14241 !      include 'COMMON.LOCAL'
14242 !      include 'COMMON.CHAIN'
14243 !      include 'COMMON.DERIV'
14244 !      include 'COMMON.NAMES'
14245 !      include 'COMMON.INTERACT'
14246 !      include 'COMMON.IOUNITS'
14247 !      include 'COMMON.CALC'
14248       use comm_srutu
14249 !el      integer :: icall
14250 !el      common /srutu/ icall
14251       logical :: lprn
14252 !el local variables
14253       integer :: iint,itypi,itypi1,itypj
14254       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij,&
14255                       sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
14256       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
14257       evdw=0.0D0
14258 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14259       evdw=0.0D0
14260       lprn=.false.
14261 !     if (icall.eq.0) lprn=.true.
14262 !el      ind=0
14263       do i=iatsc_s,iatsc_e
14264         itypi=itype(i,1)
14265         if (itypi.eq.ntyp1) cycle
14266         itypi1=itype(i+1,1)
14267         xi=c(1,nres+i)
14268         yi=c(2,nres+i)
14269         zi=c(3,nres+i)
14270         call to_box(xi,yi,zi)
14271         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14272         dxi=dc_norm(1,nres+i)
14273         dyi=dc_norm(2,nres+i)
14274         dzi=dc_norm(3,nres+i)
14275
14276 !        dsci_inv=dsc_inv(itypi)
14277         dsci_inv=vbld_inv(i+nres)
14278 !
14279 ! Calculate SC interaction energy.
14280 !
14281         do iint=1,nint_gr(i)
14282           do j=istart(i,iint),iend(i,iint)
14283 !el            ind=ind+1
14284             itypj=itype(j,1)
14285             if (itypj.eq.ntyp1) cycle
14286 !            dscj_inv=dsc_inv(itypj)
14287             dscj_inv=vbld_inv(j+nres)
14288             sig0ij=sigma(itypi,itypj)
14289             r0ij=r0(itypi,itypj)
14290             chi1=chi(itypi,itypj)
14291             chi2=chi(itypj,itypi)
14292             chi12=chi1*chi2
14293             chip1=chip(itypi)
14294             chip2=chip(itypj)
14295             chip12=chip1*chip2
14296             alf1=alp(itypi)
14297             alf2=alp(itypj)
14298             alf12=0.5D0*(alf1+alf2)
14299             xj=c(1,nres+j)-xi
14300             yj=c(2,nres+j)-yi
14301             zj=c(3,nres+j)-zi
14302             call to_box(xj,yj,zj)
14303             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14304             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14305             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14306             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14307             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14308             xj=boxshift(xj-xi,boxxsize)
14309             yj=boxshift(yj-yi,boxysize)
14310             zj=boxshift(zj-zi,boxzsize)
14311             dxj=dc_norm(1,nres+j)
14312             dyj=dc_norm(2,nres+j)
14313             dzj=dc_norm(3,nres+j)
14314             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14315             rij=dsqrt(rrij)
14316
14317             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14318
14319             if (sss.lt.1.0d0) then
14320
14321 ! Calculate angle-dependent terms of energy and contributions to their
14322 ! derivatives.
14323               call sc_angular
14324               sigsq=1.0D0/sigsq
14325               sig=sig0ij*dsqrt(sigsq)
14326               rij_shift=1.0D0/rij-sig+r0ij
14327 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14328               if (rij_shift.le.0.0D0) then
14329                 evdw=1.0D20
14330                 return
14331               endif
14332               sigder=-sig*sigsq
14333 !---------------------------------------------------------------
14334               rij_shift=1.0D0/rij_shift
14335               fac=rij_shift**expon
14336               e1=fac*fac*aa_aq(itypi,itypj)
14337               e2=fac*bb_aq(itypi,itypj)
14338               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14339               eps2der=evdwij*eps3rt
14340               eps3der=evdwij*eps2rt
14341               fac_augm=rrij**expon
14342               e_augm=augm(itypi,itypj)*fac_augm
14343               evdwij=evdwij*eps2rt*eps3rt
14344               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
14345               if (lprn) then
14346               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14347               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14348               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14349                 restyp(itypi,1),i,restyp(itypj,1),j,&
14350                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14351                 chi1,chi2,chip1,chip2,&
14352                 eps1,eps2rt**2,eps3rt**2,&
14353                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14354                 evdwij+e_augm
14355               endif
14356 ! Calculate gradient components.
14357               e1=e1*eps1*eps2rt**2*eps3rt**2
14358               fac=-expon*(e1+evdwij)*rij_shift
14359               sigder=fac*sigder
14360               fac=rij*fac-2*expon*rrij*e_augm
14361 ! Calculate the radial part of the gradient
14362               gg(1)=xj*fac
14363               gg(2)=yj*fac
14364               gg(3)=zj*fac
14365 ! Calculate angular part of the gradient.
14366               call sc_grad_scale(1.0d0-sss)
14367             endif
14368           enddo      ! j
14369         enddo        ! iint
14370       enddo          ! i
14371       end subroutine egbv_long
14372 !-----------------------------------------------------------------------------
14373       subroutine egbv_short(evdw)
14374 !
14375 ! This subroutine calculates the interaction energy of nonbonded side chains
14376 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14377 !
14378       use calc_data
14379 !      implicit real*8 (a-h,o-z)
14380 !      include 'DIMENSIONS'
14381 !      include 'COMMON.GEO'
14382 !      include 'COMMON.VAR'
14383 !      include 'COMMON.LOCAL'
14384 !      include 'COMMON.CHAIN'
14385 !      include 'COMMON.DERIV'
14386 !      include 'COMMON.NAMES'
14387 !      include 'COMMON.INTERACT'
14388 !      include 'COMMON.IOUNITS'
14389 !      include 'COMMON.CALC'
14390       use comm_srutu
14391 !el      integer :: icall
14392 !el      common /srutu/ icall
14393       logical :: lprn
14394 !el local variables
14395       integer :: iint,itypi,itypi1,itypj
14396       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift,&
14397                       sslipi,ssgradlipi, sslipj,ssgradlipj,aa,bb
14398       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
14399       evdw=0.0D0
14400 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14401       evdw=0.0D0
14402       lprn=.false.
14403 !     if (icall.eq.0) lprn=.true.
14404 !el      ind=0
14405       do i=iatsc_s,iatsc_e
14406         itypi=itype(i,1)
14407         if (itypi.eq.ntyp1) cycle
14408         itypi1=itype(i+1,1)
14409         xi=c(1,nres+i)
14410         yi=c(2,nres+i)
14411         zi=c(3,nres+i)
14412         dxi=dc_norm(1,nres+i)
14413         dyi=dc_norm(2,nres+i)
14414         dzi=dc_norm(3,nres+i)
14415         call to_box(xi,yi,zi)
14416         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14417 !        dsci_inv=dsc_inv(itypi)
14418         dsci_inv=vbld_inv(i+nres)
14419 !
14420 ! Calculate SC interaction energy.
14421 !
14422         do iint=1,nint_gr(i)
14423           do j=istart(i,iint),iend(i,iint)
14424 !el            ind=ind+1
14425             itypj=itype(j,1)
14426             if (itypj.eq.ntyp1) cycle
14427 !            dscj_inv=dsc_inv(itypj)
14428             dscj_inv=vbld_inv(j+nres)
14429             sig0ij=sigma(itypi,itypj)
14430             r0ij=r0(itypi,itypj)
14431             chi1=chi(itypi,itypj)
14432             chi2=chi(itypj,itypi)
14433             chi12=chi1*chi2
14434             chip1=chip(itypi)
14435             chip2=chip(itypj)
14436             chip12=chip1*chip2
14437             alf1=alp(itypi)
14438             alf2=alp(itypj)
14439             alf12=0.5D0*(alf1+alf2)
14440             xj=c(1,nres+j)-xi
14441             yj=c(2,nres+j)-yi
14442             zj=c(3,nres+j)-zi
14443             call to_box(xj,yj,zj)
14444             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14445             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14446             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14447             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14448             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14449             xj=boxshift(xj-xi,boxxsize)
14450             yj=boxshift(yj-yi,boxysize)
14451             zj=boxshift(zj-zi,boxzsize)
14452             dxj=dc_norm(1,nres+j)
14453             dyj=dc_norm(2,nres+j)
14454             dzj=dc_norm(3,nres+j)
14455             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14456             rij=dsqrt(rrij)
14457
14458             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14459
14460             if (sss.gt.0.0d0) then
14461
14462 ! Calculate angle-dependent terms of energy and contributions to their
14463 ! derivatives.
14464               call sc_angular
14465               sigsq=1.0D0/sigsq
14466               sig=sig0ij*dsqrt(sigsq)
14467               rij_shift=1.0D0/rij-sig+r0ij
14468 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14469               if (rij_shift.le.0.0D0) then
14470                 evdw=1.0D20
14471                 return
14472               endif
14473               sigder=-sig*sigsq
14474 !---------------------------------------------------------------
14475               rij_shift=1.0D0/rij_shift
14476               fac=rij_shift**expon
14477               e1=fac*fac*aa_aq(itypi,itypj)
14478               e2=fac*bb_aq(itypi,itypj)
14479               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14480               eps2der=evdwij*eps3rt
14481               eps3der=evdwij*eps2rt
14482               fac_augm=rrij**expon
14483               e_augm=augm(itypi,itypj)*fac_augm
14484               evdwij=evdwij*eps2rt*eps3rt
14485               evdw=evdw+(evdwij+e_augm)*sss
14486               if (lprn) then
14487               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14488               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14489               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14490                 restyp(itypi,1),i,restyp(itypj,1),j,&
14491                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14492                 chi1,chi2,chip1,chip2,&
14493                 eps1,eps2rt**2,eps3rt**2,&
14494                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14495                 evdwij+e_augm
14496               endif
14497 ! Calculate gradient components.
14498               e1=e1*eps1*eps2rt**2*eps3rt**2
14499               fac=-expon*(e1+evdwij)*rij_shift
14500               sigder=fac*sigder
14501               fac=rij*fac-2*expon*rrij*e_augm
14502 ! Calculate the radial part of the gradient
14503               gg(1)=xj*fac
14504               gg(2)=yj*fac
14505               gg(3)=zj*fac
14506 ! Calculate angular part of the gradient.
14507               call sc_grad_scale(sss)
14508             endif
14509           enddo      ! j
14510         enddo        ! iint
14511       enddo          ! i
14512       end subroutine egbv_short
14513 !-----------------------------------------------------------------------------
14514       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
14515 !
14516 ! This subroutine calculates the average interaction energy and its gradient
14517 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
14518 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
14519 ! The potential depends both on the distance of peptide-group centers and on
14520 ! the orientation of the CA-CA virtual bonds.
14521 !
14522 !      implicit real*8 (a-h,o-z)
14523
14524       use comm_locel
14525 #ifdef MPI
14526       include 'mpif.h'
14527 #endif
14528 !      include 'DIMENSIONS'
14529 !      include 'COMMON.CONTROL'
14530 !      include 'COMMON.SETUP'
14531 !      include 'COMMON.IOUNITS'
14532 !      include 'COMMON.GEO'
14533 !      include 'COMMON.VAR'
14534 !      include 'COMMON.LOCAL'
14535 !      include 'COMMON.CHAIN'
14536 !      include 'COMMON.DERIV'
14537 !      include 'COMMON.INTERACT'
14538 !      include 'COMMON.CONTACTS'
14539 !      include 'COMMON.TORSION'
14540 !      include 'COMMON.VECTORS'
14541 !      include 'COMMON.FFIELD'
14542 !      include 'COMMON.TIME1'
14543       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
14544       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
14545       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14546 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14547       real(kind=8),dimension(4) :: muij
14548 !el      integer :: num_conti,j1,j2
14549 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14550 !el                   dz_normi,xmedi,ymedi,zmedi
14551 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14552 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14553 !el          num_conti,j1,j2
14554 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14555 #ifdef MOMENT
14556       real(kind=8) :: scal_el=1.0d0
14557 #else
14558       real(kind=8) :: scal_el=0.5d0
14559 #endif
14560 ! 12/13/98
14561 ! 13-go grudnia roku pamietnego...
14562       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14563                                              0.0d0,1.0d0,0.0d0,&
14564                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14565 !el local variables
14566       integer :: i,j,k
14567       real(kind=8) :: fac
14568       real(kind=8) :: dxj,dyj,dzj
14569       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
14570
14571 !      allocate(num_cont_hb(nres)) !(maxres)
14572 !d      write(iout,*) 'In EELEC'
14573 !d      do i=1,nloctyp
14574 !d        write(iout,*) 'Type',i
14575 !d        write(iout,*) 'B1',B1(:,i)
14576 !d        write(iout,*) 'B2',B2(:,i)
14577 !d        write(iout,*) 'CC',CC(:,:,i)
14578 !d        write(iout,*) 'DD',DD(:,:,i)
14579 !d        write(iout,*) 'EE',EE(:,:,i)
14580 !d      enddo
14581 !d      call check_vecgrad
14582 !d      stop
14583       if (icheckgrad.eq.1) then
14584         do i=1,nres-1
14585           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
14586           do k=1,3
14587             dc_norm(k,i)=dc(k,i)*fac
14588           enddo
14589 !          write (iout,*) 'i',i,' fac',fac
14590         enddo
14591       endif
14592       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14593           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
14594           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
14595 !        call vec_and_deriv
14596 #ifdef TIMING
14597         time01=MPI_Wtime()
14598 #endif
14599 !        print *, "before set matrices"
14600         call set_matrices
14601 !        print *,"after set martices"
14602 #ifdef TIMING
14603         time_mat=time_mat+MPI_Wtime()-time01
14604 #endif
14605       endif
14606 !d      do i=1,nres-1
14607 !d        write (iout,*) 'i=',i
14608 !d        do k=1,3
14609 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
14610 !d        enddo
14611 !d        do k=1,3
14612 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
14613 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
14614 !d        enddo
14615 !d      enddo
14616       t_eelecij=0.0d0
14617       ees=0.0D0
14618       evdw1=0.0D0
14619       eel_loc=0.0d0
14620       eello_turn3=0.0d0
14621       eello_turn4=0.0d0
14622 !el      ind=0
14623       do i=1,nres
14624         num_cont_hb(i)=0
14625       enddo
14626 !d      print '(a)','Enter EELEC'
14627 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
14628 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14629 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14630       do i=1,nres
14631         gel_loc_loc(i)=0.0d0
14632         gcorr_loc(i)=0.0d0
14633       enddo
14634 !
14635 !
14636 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
14637 !
14638 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
14639 !
14640       do i=iturn3_start,iturn3_end
14641         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
14642         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
14643         dxi=dc(1,i)
14644         dyi=dc(2,i)
14645         dzi=dc(3,i)
14646         dx_normi=dc_norm(1,i)
14647         dy_normi=dc_norm(2,i)
14648         dz_normi=dc_norm(3,i)
14649         xmedi=c(1,i)+0.5d0*dxi
14650         ymedi=c(2,i)+0.5d0*dyi
14651         zmedi=c(3,i)+0.5d0*dzi
14652         call to_box(xmedi,ymedi,zmedi)
14653         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
14654         num_conti=0
14655         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
14656         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
14657         num_cont_hb(i)=num_conti
14658       enddo
14659       do i=iturn4_start,iturn4_end
14660         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
14661           .or. itype(i+3,1).eq.ntyp1 &
14662           .or. itype(i+4,1).eq.ntyp1) cycle
14663         dxi=dc(1,i)
14664         dyi=dc(2,i)
14665         dzi=dc(3,i)
14666         dx_normi=dc_norm(1,i)
14667         dy_normi=dc_norm(2,i)
14668         dz_normi=dc_norm(3,i)
14669         xmedi=c(1,i)+0.5d0*dxi
14670         ymedi=c(2,i)+0.5d0*dyi
14671         zmedi=c(3,i)+0.5d0*dzi
14672
14673         call to_box(xmedi,ymedi,zmedi)
14674         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
14675
14676         num_conti=num_cont_hb(i)
14677         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
14678         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
14679           call eturn4(i,eello_turn4)
14680         num_cont_hb(i)=num_conti
14681       enddo   ! i
14682 !
14683 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
14684 !
14685       do i=iatel_s,iatel_e
14686         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14687         dxi=dc(1,i)
14688         dyi=dc(2,i)
14689         dzi=dc(3,i)
14690         dx_normi=dc_norm(1,i)
14691         dy_normi=dc_norm(2,i)
14692         dz_normi=dc_norm(3,i)
14693         xmedi=c(1,i)+0.5d0*dxi
14694         ymedi=c(2,i)+0.5d0*dyi
14695         zmedi=c(3,i)+0.5d0*dzi
14696         call to_box(xmedi,ymedi,zmedi)
14697         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
14698 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14699         num_conti=num_cont_hb(i)
14700         do j=ielstart(i),ielend(i)
14701           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14702           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14703         enddo ! j
14704         num_cont_hb(i)=num_conti
14705       enddo   ! i
14706 !      write (iout,*) "Number of loop steps in EELEC:",ind
14707 !d      do i=1,nres
14708 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14709 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14710 !d      enddo
14711 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14712 !cc      eel_loc=eel_loc+eello_turn3
14713 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14714       return
14715       end subroutine eelec_scale
14716 !-----------------------------------------------------------------------------
14717       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14718 !      implicit real*8 (a-h,o-z)
14719
14720       use comm_locel
14721 !      include 'DIMENSIONS'
14722 #ifdef MPI
14723       include "mpif.h"
14724 #endif
14725 !      include 'COMMON.CONTROL'
14726 !      include 'COMMON.IOUNITS'
14727 !      include 'COMMON.GEO'
14728 !      include 'COMMON.VAR'
14729 !      include 'COMMON.LOCAL'
14730 !      include 'COMMON.CHAIN'
14731 !      include 'COMMON.DERIV'
14732 !      include 'COMMON.INTERACT'
14733 !      include 'COMMON.CONTACTS'
14734 !      include 'COMMON.TORSION'
14735 !      include 'COMMON.VECTORS'
14736 !      include 'COMMON.FFIELD'
14737 !      include 'COMMON.TIME1'
14738       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14739       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14740       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14741 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14742       real(kind=8),dimension(4) :: muij
14743       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14744                     dist_temp, dist_init,sss_grad
14745       integer xshift,yshift,zshift
14746
14747 !el      integer :: num_conti,j1,j2
14748 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14749 !el                   dz_normi,xmedi,ymedi,zmedi
14750 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14751 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14752 !el          num_conti,j1,j2
14753 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14754 #ifdef MOMENT
14755       real(kind=8) :: scal_el=1.0d0
14756 #else
14757       real(kind=8) :: scal_el=0.5d0
14758 #endif
14759 ! 12/13/98
14760 ! 13-go grudnia roku pamietnego...
14761       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14762                                              0.0d0,1.0d0,0.0d0,&
14763                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14764 !el local variables
14765       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
14766       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
14767       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
14768       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
14769       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
14770       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
14771       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
14772                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
14773                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
14774                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
14775                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
14776                   ecosam,ecosbm,ecosgm,ghalf,time00,faclipij,faclipij2
14777 !      integer :: maxconts
14778 !      maxconts = nres/4
14779 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14780 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14781 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14782 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14783 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14784 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14785 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14786 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14787 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
14788 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
14789 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
14790 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
14791 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
14792
14793 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
14794 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
14795
14796 #ifdef MPI
14797           time00=MPI_Wtime()
14798 #endif
14799 !d      write (iout,*) "eelecij",i,j
14800 !el          ind=ind+1
14801           iteli=itel(i)
14802           itelj=itel(j)
14803           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14804           aaa=app(iteli,itelj)
14805           bbb=bpp(iteli,itelj)
14806           ael6i=ael6(iteli,itelj)
14807           ael3i=ael3(iteli,itelj)
14808           dxj=dc(1,j)
14809           dyj=dc(2,j)
14810           dzj=dc(3,j)
14811           dx_normj=dc_norm(1,j)
14812           dy_normj=dc_norm(2,j)
14813           dz_normj=dc_norm(3,j)
14814 !          xj=c(1,j)+0.5D0*dxj-xmedi
14815 !          yj=c(2,j)+0.5D0*dyj-ymedi
14816 !          zj=c(3,j)+0.5D0*dzj-zmedi
14817           xj=c(1,j)+0.5D0*dxj
14818           yj=c(2,j)+0.5D0*dyj
14819           zj=c(3,j)+0.5D0*dzj
14820           call to_box(xj,yj,zj)
14821           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14822           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
14823           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
14824           xj=boxshift(xj-xmedi,boxxsize)
14825           yj=boxshift(yj-ymedi,boxysize)
14826           zj=boxshift(zj-zmedi,boxzsize)
14827           rij=xj*xj+yj*yj+zj*zj
14828           rrmij=1.0D0/rij
14829           rij=dsqrt(rij)
14830           rmij=1.0D0/rij
14831 ! For extracting the short-range part of Evdwpp
14832           sss=sscale(rij/rpp(iteli,itelj))
14833             sss_ele_cut=sscale_ele(rij)
14834             sss_ele_grad=sscagrad_ele(rij)
14835             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14836 !             sss_ele_cut=1.0d0
14837 !             sss_ele_grad=0.0d0
14838             if (sss_ele_cut.le.0.0) go to 128
14839
14840           r3ij=rrmij*rmij
14841           r6ij=r3ij*r3ij
14842           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
14843           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
14844           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
14845           fac=cosa-3.0D0*cosb*cosg
14846           ev1=aaa*r6ij*r6ij
14847 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14848           if (j.eq.i+2) ev1=scal_el*ev1
14849           ev2=bbb*r6ij
14850           fac3=ael6i*r6ij
14851           fac4=ael3i*r3ij
14852           evdwij=ev1+ev2
14853           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
14854           el2=fac4*fac
14855           eesij=el1+el2
14856 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
14857           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
14858           ees=ees+eesij*sss_ele_cut
14859           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
14860 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
14861 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
14862 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
14863 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
14864
14865           if (energy_dec) then
14866               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14867               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
14868           endif
14869
14870 !
14871 ! Calculate contributions to the Cartesian gradient.
14872 !
14873 #ifdef SPLITELE
14874           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14875           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
14876           fac1=fac
14877           erij(1)=xj*rmij
14878           erij(2)=yj*rmij
14879           erij(3)=zj*rmij
14880 !
14881 ! Radial derivatives. First process both termini of the fragment (i,j)
14882 !
14883           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
14884           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
14885           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
14886 !          do k=1,3
14887 !            ghalf=0.5D0*ggg(k)
14888 !            gelc(k,i)=gelc(k,i)+ghalf
14889 !            gelc(k,j)=gelc(k,j)+ghalf
14890 !          enddo
14891 ! 9/28/08 AL Gradient compotents will be summed only at the end
14892           do k=1,3
14893             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14894             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14895           enddo
14896 !
14897 ! Loop over residues i+1 thru j-1.
14898 !
14899 !grad          do k=i+1,j-1
14900 !grad            do l=1,3
14901 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14902 !grad            enddo
14903 !grad          enddo
14904           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
14905           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14906           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
14907           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14908           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
14909           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14910 !          do k=1,3
14911 !            ghalf=0.5D0*ggg(k)
14912 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
14913 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
14914 !          enddo
14915 ! 9/28/08 AL Gradient compotents will be summed only at the end
14916           do k=1,3
14917             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14918             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14919           enddo
14920 !
14921 ! Loop over residues i+1 thru j-1.
14922 !
14923 !grad          do k=i+1,j-1
14924 !grad            do l=1,3
14925 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
14926 !grad            enddo
14927 !grad          enddo
14928 #else
14929           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14930           facel=(el1+eesij)*sss_ele_cut
14931           fac1=fac
14932           fac=-3*rrmij*(facvdw+facvdw+facel)
14933           erij(1)=xj*rmij
14934           erij(2)=yj*rmij
14935           erij(3)=zj*rmij
14936 !
14937 ! Radial derivatives. First process both termini of the fragment (i,j)
14938 !
14939           ggg(1)=fac*xj
14940           ggg(2)=fac*yj
14941           ggg(3)=fac*zj
14942 !          do k=1,3
14943 !            ghalf=0.5D0*ggg(k)
14944 !            gelc(k,i)=gelc(k,i)+ghalf
14945 !            gelc(k,j)=gelc(k,j)+ghalf
14946 !          enddo
14947 ! 9/28/08 AL Gradient compotents will be summed only at the end
14948           do k=1,3
14949             gelc_long(k,j)=gelc(k,j)+ggg(k)
14950             gelc_long(k,i)=gelc(k,i)-ggg(k)
14951           enddo
14952 !
14953 ! Loop over residues i+1 thru j-1.
14954 !
14955 !grad          do k=i+1,j-1
14956 !grad            do l=1,3
14957 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14958 !grad            enddo
14959 !grad          enddo
14960 ! 9/28/08 AL Gradient compotents will be summed only at the end
14961           ggg(1)=facvdw*xj
14962           ggg(2)=facvdw*yj
14963           ggg(3)=facvdw*zj
14964           do k=1,3
14965             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14966             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14967           enddo
14968 #endif
14969 !
14970 ! Angular part
14971 !
14972           ecosa=2.0D0*fac3*fac1+fac4
14973           fac4=-3.0D0*fac4
14974           fac3=-6.0D0*fac3
14975           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
14976           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
14977           do k=1,3
14978             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14979             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14980           enddo
14981 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
14982 !d   &          (dcosg(k),k=1,3)
14983           do k=1,3
14984             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
14985           enddo
14986 !          do k=1,3
14987 !            ghalf=0.5D0*ggg(k)
14988 !            gelc(k,i)=gelc(k,i)+ghalf
14989 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
14990 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14991 !            gelc(k,j)=gelc(k,j)+ghalf
14992 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
14993 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14994 !          enddo
14995 !grad          do k=i+1,j-1
14996 !grad            do l=1,3
14997 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14998 !grad            enddo
14999 !grad          enddo
15000           do k=1,3
15001             gelc(k,i)=gelc(k,i) &
15002                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15003                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
15004                      *sss_ele_cut
15005             gelc(k,j)=gelc(k,j) &
15006                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15007                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15008                      *sss_ele_cut
15009             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15010             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15011           enddo
15012           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
15013               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
15014               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15015 !
15016 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
15017 !   energy of a peptide unit is assumed in the form of a second-order
15018 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
15019 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
15020 !   are computed for EVERY pair of non-contiguous peptide groups.
15021 !
15022           if (j.lt.nres-1) then
15023             j1=j+1
15024             j2=j-1
15025           else
15026             j1=j-1
15027             j2=j-2
15028           endif
15029           kkk=0
15030           do k=1,2
15031             do l=1,2
15032               kkk=kkk+1
15033               muij(kkk)=mu(k,i)*mu(l,j)
15034             enddo
15035           enddo
15036 !d         write (iout,*) 'EELEC: i',i,' j',j
15037 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
15038 !d          write(iout,*) 'muij',muij
15039           ury=scalar(uy(1,i),erij)
15040           urz=scalar(uz(1,i),erij)
15041           vry=scalar(uy(1,j),erij)
15042           vrz=scalar(uz(1,j),erij)
15043           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
15044           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
15045           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
15046           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
15047           fac=dsqrt(-ael6i)*r3ij
15048           a22=a22*fac
15049           a23=a23*fac
15050           a32=a32*fac
15051           a33=a33*fac
15052 !d          write (iout,'(4i5,4f10.5)')
15053 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
15054 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
15055 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
15056 !d     &      uy(:,j),uz(:,j)
15057 !d          write (iout,'(4f10.5)')
15058 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
15059 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
15060 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
15061 !d           write (iout,'(9f10.5/)')
15062 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
15063 ! Derivatives of the elements of A in virtual-bond vectors
15064           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
15065           do k=1,3
15066             uryg(k,1)=scalar(erder(1,k),uy(1,i))
15067             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
15068             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
15069             urzg(k,1)=scalar(erder(1,k),uz(1,i))
15070             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
15071             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
15072             vryg(k,1)=scalar(erder(1,k),uy(1,j))
15073             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
15074             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
15075             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
15076             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
15077             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
15078           enddo
15079 ! Compute radial contributions to the gradient
15080           facr=-3.0d0*rrmij
15081           a22der=a22*facr
15082           a23der=a23*facr
15083           a32der=a32*facr
15084           a33der=a33*facr
15085           agg(1,1)=a22der*xj
15086           agg(2,1)=a22der*yj
15087           agg(3,1)=a22der*zj
15088           agg(1,2)=a23der*xj
15089           agg(2,2)=a23der*yj
15090           agg(3,2)=a23der*zj
15091           agg(1,3)=a32der*xj
15092           agg(2,3)=a32der*yj
15093           agg(3,3)=a32der*zj
15094           agg(1,4)=a33der*xj
15095           agg(2,4)=a33der*yj
15096           agg(3,4)=a33der*zj
15097 ! Add the contributions coming from er
15098           fac3=-3.0d0*fac
15099           do k=1,3
15100             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
15101             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
15102             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
15103             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
15104           enddo
15105           do k=1,3
15106 ! Derivatives in DC(i)
15107 !grad            ghalf1=0.5d0*agg(k,1)
15108 !grad            ghalf2=0.5d0*agg(k,2)
15109 !grad            ghalf3=0.5d0*agg(k,3)
15110 !grad            ghalf4=0.5d0*agg(k,4)
15111             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
15112             -3.0d0*uryg(k,2)*vry)!+ghalf1
15113             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
15114             -3.0d0*uryg(k,2)*vrz)!+ghalf2
15115             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
15116             -3.0d0*urzg(k,2)*vry)!+ghalf3
15117             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
15118             -3.0d0*urzg(k,2)*vrz)!+ghalf4
15119 ! Derivatives in DC(i+1)
15120             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
15121             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
15122             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
15123             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
15124             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
15125             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
15126             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
15127             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
15128 ! Derivatives in DC(j)
15129             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
15130             -3.0d0*vryg(k,2)*ury)!+ghalf1
15131             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
15132             -3.0d0*vrzg(k,2)*ury)!+ghalf2
15133             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
15134             -3.0d0*vryg(k,2)*urz)!+ghalf3
15135             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
15136             -3.0d0*vrzg(k,2)*urz)!+ghalf4
15137 ! Derivatives in DC(j+1) or DC(nres-1)
15138             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
15139             -3.0d0*vryg(k,3)*ury)
15140             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
15141             -3.0d0*vrzg(k,3)*ury)
15142             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
15143             -3.0d0*vryg(k,3)*urz)
15144             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
15145             -3.0d0*vrzg(k,3)*urz)
15146 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
15147 !grad              do l=1,4
15148 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
15149 !grad              enddo
15150 !grad            endif
15151           enddo
15152           acipa(1,1)=a22
15153           acipa(1,2)=a23
15154           acipa(2,1)=a32
15155           acipa(2,2)=a33
15156           a22=-a22
15157           a23=-a23
15158           do l=1,2
15159             do k=1,3
15160               agg(k,l)=-agg(k,l)
15161               aggi(k,l)=-aggi(k,l)
15162               aggi1(k,l)=-aggi1(k,l)
15163               aggj(k,l)=-aggj(k,l)
15164               aggj1(k,l)=-aggj1(k,l)
15165             enddo
15166           enddo
15167           if (j.lt.nres-1) then
15168             a22=-a22
15169             a32=-a32
15170             do l=1,3,2
15171               do k=1,3
15172                 agg(k,l)=-agg(k,l)
15173                 aggi(k,l)=-aggi(k,l)
15174                 aggi1(k,l)=-aggi1(k,l)
15175                 aggj(k,l)=-aggj(k,l)
15176                 aggj1(k,l)=-aggj1(k,l)
15177               enddo
15178             enddo
15179           else
15180             a22=-a22
15181             a23=-a23
15182             a32=-a32
15183             a33=-a33
15184             do l=1,4
15185               do k=1,3
15186                 agg(k,l)=-agg(k,l)
15187                 aggi(k,l)=-aggi(k,l)
15188                 aggi1(k,l)=-aggi1(k,l)
15189                 aggj(k,l)=-aggj(k,l)
15190                 aggj1(k,l)=-aggj1(k,l)
15191               enddo
15192             enddo
15193           endif
15194           ENDIF ! WCORR
15195           IF (wel_loc.gt.0.0d0) THEN
15196 ! Contribution to the local-electrostatic energy coming from the i-j pair
15197           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
15198            +a33*muij(4)
15199 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
15200 !           print *,"EELLOC",i,gel_loc_loc(i-1)
15201           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
15202                   'eelloc',i,j,eel_loc_ij
15203 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
15204
15205           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
15206 ! Partial derivatives in virtual-bond dihedral angles gamma
15207           if (i.gt.1) &
15208           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
15209                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
15210                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
15211                  *sss_ele_cut
15212           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
15213                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
15214                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
15215                  *sss_ele_cut
15216            xtemp(1)=xj
15217            xtemp(2)=yj
15218            xtemp(3)=zj
15219
15220 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
15221           do l=1,3
15222             ggg(l)=(agg(l,1)*muij(1)+ &
15223                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
15224             *sss_ele_cut &
15225              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
15226
15227             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
15228             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
15229 !grad            ghalf=0.5d0*ggg(l)
15230 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
15231 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
15232           enddo
15233 !grad          do k=i+1,j2
15234 !grad            do l=1,3
15235 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
15236 !grad            enddo
15237 !grad          enddo
15238 ! Remaining derivatives of eello
15239           do l=1,3
15240             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
15241                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
15242             *sss_ele_cut
15243
15244             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
15245                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
15246             *sss_ele_cut
15247
15248             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
15249                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
15250             *sss_ele_cut
15251
15252             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
15253                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
15254             *sss_ele_cut
15255
15256           enddo
15257           ENDIF
15258 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
15259 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
15260           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
15261              .and. num_conti.le.maxconts) then
15262 !            write (iout,*) i,j," entered corr"
15263 !
15264 ! Calculate the contact function. The ith column of the array JCONT will
15265 ! contain the numbers of atoms that make contacts with the atom I (of numbers
15266 ! greater than I). The arrays FACONT and GACONT will contain the values of
15267 ! the contact function and its derivative.
15268 !           r0ij=1.02D0*rpp(iteli,itelj)
15269 !           r0ij=1.11D0*rpp(iteli,itelj)
15270             r0ij=2.20D0*rpp(iteli,itelj)
15271 !           r0ij=1.55D0*rpp(iteli,itelj)
15272             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
15273 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15274             if (fcont.gt.0.0D0) then
15275               num_conti=num_conti+1
15276               if (num_conti.gt.maxconts) then
15277 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15278                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
15279                                ' will skip next contacts for this conf.',num_conti
15280               else
15281                 jcont_hb(num_conti,i)=j
15282 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
15283 !d     &           " jcont_hb",jcont_hb(num_conti,i)
15284                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
15285                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15286 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
15287 !  terms.
15288                 d_cont(num_conti,i)=rij
15289 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
15290 !     --- Electrostatic-interaction matrix ---
15291                 a_chuj(1,1,num_conti,i)=a22
15292                 a_chuj(1,2,num_conti,i)=a23
15293                 a_chuj(2,1,num_conti,i)=a32
15294                 a_chuj(2,2,num_conti,i)=a33
15295 !     --- Gradient of rij
15296                 do kkk=1,3
15297                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
15298                 enddo
15299                 kkll=0
15300                 do k=1,2
15301                   do l=1,2
15302                     kkll=kkll+1
15303                     do m=1,3
15304                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
15305                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
15306                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
15307                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
15308                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
15309                     enddo
15310                   enddo
15311                 enddo
15312                 ENDIF
15313                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
15314 ! Calculate contact energies
15315                 cosa4=4.0D0*cosa
15316                 wij=cosa-3.0D0*cosb*cosg
15317                 cosbg1=cosb+cosg
15318                 cosbg2=cosb-cosg
15319 !               fac3=dsqrt(-ael6i)/r0ij**3
15320                 fac3=dsqrt(-ael6i)*r3ij
15321 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
15322                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
15323                 if (ees0tmp.gt.0) then
15324                   ees0pij=dsqrt(ees0tmp)
15325                 else
15326                   ees0pij=0
15327                 endif
15328 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
15329                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
15330                 if (ees0tmp.gt.0) then
15331                   ees0mij=dsqrt(ees0tmp)
15332                 else
15333                   ees0mij=0
15334                 endif
15335 !               ees0mij=0.0D0
15336                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
15337                      *sss_ele_cut
15338
15339                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
15340                      *sss_ele_cut
15341
15342 ! Diagnostics. Comment out or remove after debugging!
15343 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
15344 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
15345 !               ees0m(num_conti,i)=0.0D0
15346 ! End diagnostics.
15347 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
15348 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
15349 ! Angular derivatives of the contact function
15350                 ees0pij1=fac3/ees0pij
15351                 ees0mij1=fac3/ees0mij
15352                 fac3p=-3.0D0*fac3*rrmij
15353                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
15354                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
15355 !               ees0mij1=0.0D0
15356                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
15357                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
15358                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
15359                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
15360                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
15361                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
15362                 ecosap=ecosa1+ecosa2
15363                 ecosbp=ecosb1+ecosb2
15364                 ecosgp=ecosg1+ecosg2
15365                 ecosam=ecosa1-ecosa2
15366                 ecosbm=ecosb1-ecosb2
15367                 ecosgm=ecosg1-ecosg2
15368 ! Diagnostics
15369 !               ecosap=ecosa1
15370 !               ecosbp=ecosb1
15371 !               ecosgp=ecosg1
15372 !               ecosam=0.0D0
15373 !               ecosbm=0.0D0
15374 !               ecosgm=0.0D0
15375 ! End diagnostics
15376                 facont_hb(num_conti,i)=fcont
15377                 fprimcont=fprimcont/rij
15378 !d              facont_hb(num_conti,i)=1.0D0
15379 ! Following line is for diagnostics.
15380 !d              fprimcont=0.0D0
15381                 do k=1,3
15382                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15383                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15384                 enddo
15385                 do k=1,3
15386                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
15387                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
15388                 enddo
15389 !                gggp(1)=gggp(1)+ees0pijp*xj
15390 !                gggp(2)=gggp(2)+ees0pijp*yj
15391 !                gggp(3)=gggp(3)+ees0pijp*zj
15392 !                gggm(1)=gggm(1)+ees0mijp*xj
15393 !                gggm(2)=gggm(2)+ees0mijp*yj
15394 !                gggm(3)=gggm(3)+ees0mijp*zj
15395                 gggp(1)=gggp(1)+ees0pijp*xj &
15396                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15397                 gggp(2)=gggp(2)+ees0pijp*yj &
15398                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15399                 gggp(3)=gggp(3)+ees0pijp*zj &
15400                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15401
15402                 gggm(1)=gggm(1)+ees0mijp*xj &
15403                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15404
15405                 gggm(2)=gggm(2)+ees0mijp*yj &
15406                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15407
15408                 gggm(3)=gggm(3)+ees0mijp*zj &
15409                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15410
15411 ! Derivatives due to the contact function
15412                 gacont_hbr(1,num_conti,i)=fprimcont*xj
15413                 gacont_hbr(2,num_conti,i)=fprimcont*yj
15414                 gacont_hbr(3,num_conti,i)=fprimcont*zj
15415                 do k=1,3
15416 !
15417 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
15418 !          following the change of gradient-summation algorithm.
15419 !
15420 !grad                  ghalfp=0.5D0*gggp(k)
15421 !grad                  ghalfm=0.5D0*gggm(k)
15422 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
15423 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15424 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15425 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
15426 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15427 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15428 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
15429 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
15430 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15431 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15432 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
15433 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15434 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15435 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
15436                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
15437                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15438                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15439                      *sss_ele_cut
15440
15441                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
15442                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15443                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15444                      *sss_ele_cut
15445
15446                   gacontp_hb3(k,num_conti,i)=gggp(k) &
15447                      *sss_ele_cut
15448
15449                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
15450                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15451                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15452                      *sss_ele_cut
15453
15454                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
15455                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15456                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
15457                      *sss_ele_cut
15458
15459                   gacontm_hb3(k,num_conti,i)=gggm(k) &
15460                      *sss_ele_cut
15461
15462                 enddo
15463               ENDIF ! wcorr
15464               endif  ! num_conti.le.maxconts
15465             endif  ! fcont.gt.0
15466           endif    ! j.gt.i+1
15467           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
15468             do k=1,4
15469               do l=1,3
15470                 ghalf=0.5d0*agg(l,k)
15471                 aggi(l,k)=aggi(l,k)+ghalf
15472                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
15473                 aggj(l,k)=aggj(l,k)+ghalf
15474               enddo
15475             enddo
15476             if (j.eq.nres-1 .and. i.lt.j-2) then
15477               do k=1,4
15478                 do l=1,3
15479                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
15480                 enddo
15481               enddo
15482             endif
15483           endif
15484  128      continue
15485 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
15486       return
15487       end subroutine eelecij_scale
15488 !-----------------------------------------------------------------------------
15489       subroutine evdwpp_short(evdw1)
15490 !
15491 ! Compute Evdwpp
15492 !
15493 !      implicit real*8 (a-h,o-z)
15494 !      include 'DIMENSIONS'
15495 !      include 'COMMON.CONTROL'
15496 !      include 'COMMON.IOUNITS'
15497 !      include 'COMMON.GEO'
15498 !      include 'COMMON.VAR'
15499 !      include 'COMMON.LOCAL'
15500 !      include 'COMMON.CHAIN'
15501 !      include 'COMMON.DERIV'
15502 !      include 'COMMON.INTERACT'
15503 !      include 'COMMON.CONTACTS'
15504 !      include 'COMMON.TORSION'
15505 !      include 'COMMON.VECTORS'
15506 !      include 'COMMON.FFIELD'
15507       real(kind=8),dimension(3) :: ggg
15508 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15509 #ifdef MOMENT
15510       real(kind=8) :: scal_el=1.0d0
15511 #else
15512       real(kind=8) :: scal_el=0.5d0
15513 #endif
15514 !el local variables
15515       integer :: i,j,k,iteli,itelj,num_conti,isubchap
15516       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
15517       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
15518                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15519                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
15520       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15521                     dist_temp, dist_init,sss_grad,sslipi,ssgradlipi,&
15522                    sslipj,ssgradlipj,faclipij2
15523       integer xshift,yshift,zshift
15524
15525
15526       evdw1=0.0D0
15527 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
15528 !     & " iatel_e_vdw",iatel_e_vdw
15529       call flush(iout)
15530       do i=iatel_s_vdw,iatel_e_vdw
15531         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
15532         dxi=dc(1,i)
15533         dyi=dc(2,i)
15534         dzi=dc(3,i)
15535         dx_normi=dc_norm(1,i)
15536         dy_normi=dc_norm(2,i)
15537         dz_normi=dc_norm(3,i)
15538         xmedi=c(1,i)+0.5d0*dxi
15539         ymedi=c(2,i)+0.5d0*dyi
15540         zmedi=c(3,i)+0.5d0*dzi
15541         call to_box(xmedi,ymedi,zmedi)
15542         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
15543         num_conti=0
15544 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
15545 !     &   ' ielend',ielend_vdw(i)
15546         call flush(iout)
15547         do j=ielstart_vdw(i),ielend_vdw(i)
15548           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15549 !el          ind=ind+1
15550           iteli=itel(i)
15551           itelj=itel(j)
15552           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15553           aaa=app(iteli,itelj)
15554           bbb=bpp(iteli,itelj)
15555           dxj=dc(1,j)
15556           dyj=dc(2,j)
15557           dzj=dc(3,j)
15558           dx_normj=dc_norm(1,j)
15559           dy_normj=dc_norm(2,j)
15560           dz_normj=dc_norm(3,j)
15561 !          xj=c(1,j)+0.5D0*dxj-xmedi
15562 !          yj=c(2,j)+0.5D0*dyj-ymedi
15563 !          zj=c(3,j)+0.5D0*dzj-zmedi
15564           xj=c(1,j)+0.5D0*dxj
15565           yj=c(2,j)+0.5D0*dyj
15566           zj=c(3,j)+0.5D0*dzj
15567           call to_box(xj,yj,zj)
15568           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15569           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
15570           xj=boxshift(xj-xmedi,boxxsize)
15571           yj=boxshift(yj-ymedi,boxysize)
15572           zj=boxshift(zj-zmedi,boxzsize)
15573           rij=xj*xj+yj*yj+zj*zj
15574           rrmij=1.0D0/rij
15575           rij=dsqrt(rij)
15576           sss=sscale(rij/rpp(iteli,itelj))
15577             sss_ele_cut=sscale_ele(rij)
15578             sss_ele_grad=sscagrad_ele(rij)
15579             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15580             if (sss_ele_cut.le.0.0) cycle
15581           if (sss.gt.0.0d0) then
15582             rmij=1.0D0/rij
15583             r3ij=rrmij*rmij
15584             r6ij=r3ij*r3ij
15585             ev1=aaa*r6ij*r6ij
15586 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15587             if (j.eq.i+2) ev1=scal_el*ev1
15588             ev2=bbb*r6ij
15589             evdwij=ev1+ev2
15590             if (energy_dec) then
15591               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15592             endif
15593             evdw1=evdw1+evdwij*sss*sss_ele_cut
15594 !
15595 ! Calculate contributions to the Cartesian gradient.
15596 !
15597             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
15598 !            ggg(1)=facvdw*xj
15599 !            ggg(2)=facvdw*yj
15600 !            ggg(3)=facvdw*zj
15601           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
15602           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15603           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
15604           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15605           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
15606           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15607
15608             do k=1,3
15609               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15610               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15611             enddo
15612           endif
15613         enddo ! j
15614       enddo   ! i
15615       return
15616       end subroutine evdwpp_short
15617 !-----------------------------------------------------------------------------
15618       subroutine escp_long(evdw2,evdw2_14)
15619 !
15620 ! This subroutine calculates the excluded-volume interaction energy between
15621 ! peptide-group centers and side chains and its gradient in virtual-bond and
15622 ! side-chain vectors.
15623 !
15624 !      implicit real*8 (a-h,o-z)
15625 !      include 'DIMENSIONS'
15626 !      include 'COMMON.GEO'
15627 !      include 'COMMON.VAR'
15628 !      include 'COMMON.LOCAL'
15629 !      include 'COMMON.CHAIN'
15630 !      include 'COMMON.DERIV'
15631 !      include 'COMMON.INTERACT'
15632 !      include 'COMMON.FFIELD'
15633 !      include 'COMMON.IOUNITS'
15634 !      include 'COMMON.CONTROL'
15635       real(kind=8),dimension(3) :: ggg
15636 !el local variables
15637       integer :: i,iint,j,k,iteli,itypj,subchap
15638       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15639       real(kind=8) :: evdw2,evdw2_14,evdwij
15640       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15641                     dist_temp, dist_init
15642
15643       evdw2=0.0D0
15644       evdw2_14=0.0d0
15645 !d    print '(a)','Enter ESCP'
15646 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15647       do i=iatscp_s,iatscp_e
15648         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15649         iteli=itel(i)
15650         xi=0.5D0*(c(1,i)+c(1,i+1))
15651         yi=0.5D0*(c(2,i)+c(2,i+1))
15652         zi=0.5D0*(c(3,i)+c(3,i+1))
15653         call to_box(xi,yi,zi)
15654         do iint=1,nscp_gr(i)
15655
15656         do j=iscpstart(i,iint),iscpend(i,iint)
15657           itypj=itype(j,1)
15658           if (itypj.eq.ntyp1) cycle
15659 ! Uncomment following three lines for SC-p interactions
15660 !         xj=c(1,nres+j)-xi
15661 !         yj=c(2,nres+j)-yi
15662 !         zj=c(3,nres+j)-zi
15663 ! Uncomment following three lines for Ca-p interactions
15664           xj=c(1,j)
15665           yj=c(2,j)
15666           zj=c(3,j)
15667           call to_box(xj,yj,zj)
15668           xj=boxshift(xj-xi,boxxsize)
15669           yj=boxshift(yj-yi,boxysize)
15670           zj=boxshift(zj-zi,boxzsize)
15671           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15672
15673           rij=dsqrt(1.0d0/rrij)
15674             sss_ele_cut=sscale_ele(rij)
15675             sss_ele_grad=sscagrad_ele(rij)
15676 !            print *,sss_ele_cut,sss_ele_grad,&
15677 !            (rij),r_cut_ele,rlamb_ele
15678             if (sss_ele_cut.le.0.0) cycle
15679           sss=sscale((rij/rscp(itypj,iteli)))
15680           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15681           if (sss.lt.1.0d0) then
15682
15683             fac=rrij**expon2
15684             e1=fac*fac*aad(itypj,iteli)
15685             e2=fac*bad(itypj,iteli)
15686             if (iabs(j-i) .le. 2) then
15687               e1=scal14*e1
15688               e2=scal14*e2
15689               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
15690             endif
15691             evdwij=e1+e2
15692             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
15693             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15694                 'evdw2',i,j,sss,evdwij
15695 !
15696 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15697 !
15698             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
15699             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
15700             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15701             ggg(1)=xj*fac
15702             ggg(2)=yj*fac
15703             ggg(3)=zj*fac
15704 ! Uncomment following three lines for SC-p interactions
15705 !           do k=1,3
15706 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15707 !           enddo
15708 ! Uncomment following line for SC-p interactions
15709 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15710             do k=1,3
15711               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15712               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15713             enddo
15714           endif
15715         enddo
15716
15717         enddo ! iint
15718       enddo ! i
15719       do i=1,nct
15720         do j=1,3
15721           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15722           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15723           gradx_scp(j,i)=expon*gradx_scp(j,i)
15724         enddo
15725       enddo
15726 !******************************************************************************
15727 !
15728 !                              N O T E !!!
15729 !
15730 ! To save time the factor EXPON has been extracted from ALL components
15731 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15732 ! use!
15733 !
15734 !******************************************************************************
15735       return
15736       end subroutine escp_long
15737 !-----------------------------------------------------------------------------
15738       subroutine escp_short(evdw2,evdw2_14)
15739 !
15740 ! This subroutine calculates the excluded-volume interaction energy between
15741 ! peptide-group centers and side chains and its gradient in virtual-bond and
15742 ! side-chain vectors.
15743 !
15744 !      implicit real*8 (a-h,o-z)
15745 !      include 'DIMENSIONS'
15746 !      include 'COMMON.GEO'
15747 !      include 'COMMON.VAR'
15748 !      include 'COMMON.LOCAL'
15749 !      include 'COMMON.CHAIN'
15750 !      include 'COMMON.DERIV'
15751 !      include 'COMMON.INTERACT'
15752 !      include 'COMMON.FFIELD'
15753 !      include 'COMMON.IOUNITS'
15754 !      include 'COMMON.CONTROL'
15755       real(kind=8),dimension(3) :: ggg
15756 !el local variables
15757       integer :: i,iint,j,k,iteli,itypj,subchap
15758       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15759       real(kind=8) :: evdw2,evdw2_14,evdwij
15760       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15761                     dist_temp, dist_init
15762
15763       evdw2=0.0D0
15764       evdw2_14=0.0d0
15765 !d    print '(a)','Enter ESCP'
15766 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15767       do i=iatscp_s,iatscp_e
15768         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15769         iteli=itel(i)
15770         xi=0.5D0*(c(1,i)+c(1,i+1))
15771         yi=0.5D0*(c(2,i)+c(2,i+1))
15772         zi=0.5D0*(c(3,i)+c(3,i+1))
15773         call to_box(xi,yi,zi)
15774         if (zi.lt.0) zi=zi+boxzsize
15775
15776         do iint=1,nscp_gr(i)
15777
15778         do j=iscpstart(i,iint),iscpend(i,iint)
15779           itypj=itype(j,1)
15780           if (itypj.eq.ntyp1) cycle
15781 ! Uncomment following three lines for SC-p interactions
15782 !         xj=c(1,nres+j)-xi
15783 !         yj=c(2,nres+j)-yi
15784 !         zj=c(3,nres+j)-zi
15785 ! Uncomment following three lines for Ca-p interactions
15786 !          xj=c(1,j)-xi
15787 !          yj=c(2,j)-yi
15788 !          zj=c(3,j)-zi
15789           xj=c(1,j)
15790           yj=c(2,j)
15791           zj=c(3,j)
15792           call to_box(xj,yj,zj)
15793           xj=boxshift(xj-xi,boxxsize)
15794           yj=boxshift(yj-yi,boxysize)
15795           zj=boxshift(zj-zi,boxzsize)
15796           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15797           rij=dsqrt(1.0d0/rrij)
15798             sss_ele_cut=sscale_ele(rij)
15799             sss_ele_grad=sscagrad_ele(rij)
15800 !            print *,sss_ele_cut,sss_ele_grad,&
15801 !            (rij),r_cut_ele,rlamb_ele
15802             if (sss_ele_cut.le.0.0) cycle
15803           sss=sscale(rij/rscp(itypj,iteli))
15804           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15805           if (sss.gt.0.0d0) then
15806
15807             fac=rrij**expon2
15808             e1=fac*fac*aad(itypj,iteli)
15809             e2=fac*bad(itypj,iteli)
15810             if (iabs(j-i) .le. 2) then
15811               e1=scal14*e1
15812               e2=scal14*e2
15813               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
15814             endif
15815             evdwij=e1+e2
15816             evdw2=evdw2+evdwij*sss*sss_ele_cut
15817             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15818                 'evdw2',i,j,sss,evdwij
15819 !
15820 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15821 !
15822             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
15823             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
15824             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15825
15826             ggg(1)=xj*fac
15827             ggg(2)=yj*fac
15828             ggg(3)=zj*fac
15829 ! Uncomment following three lines for SC-p interactions
15830 !           do k=1,3
15831 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15832 !           enddo
15833 ! Uncomment following line for SC-p interactions
15834 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15835             do k=1,3
15836               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15837               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15838             enddo
15839           endif
15840         enddo
15841
15842         enddo ! iint
15843       enddo ! i
15844       do i=1,nct
15845         do j=1,3
15846           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15847           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15848           gradx_scp(j,i)=expon*gradx_scp(j,i)
15849         enddo
15850       enddo
15851 !******************************************************************************
15852 !
15853 !                              N O T E !!!
15854 !
15855 ! To save time the factor EXPON has been extracted from ALL components
15856 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15857 ! use!
15858 !
15859 !******************************************************************************
15860       return
15861       end subroutine escp_short
15862 !-----------------------------------------------------------------------------
15863 ! energy_p_new-sep_barrier.F
15864 !-----------------------------------------------------------------------------
15865       subroutine sc_grad_scale(scalfac)
15866 !      implicit real*8 (a-h,o-z)
15867       use calc_data
15868 !      include 'DIMENSIONS'
15869 !      include 'COMMON.CHAIN'
15870 !      include 'COMMON.DERIV'
15871 !      include 'COMMON.CALC'
15872 !      include 'COMMON.IOUNITS'
15873       real(kind=8),dimension(3) :: dcosom1,dcosom2
15874       real(kind=8) :: scalfac
15875 !el local variables
15876 !      integer :: i,j,k,l
15877
15878       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15879       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15880       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
15881            -2.0D0*alf12*eps3der+sigder*sigsq_om12
15882 ! diagnostics only
15883 !      eom1=0.0d0
15884 !      eom2=0.0d0
15885 !      eom12=evdwij*eps1_om12
15886 ! end diagnostics
15887 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
15888 !     &  " sigder",sigder
15889 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
15890 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
15891       do k=1,3
15892         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
15893         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
15894       enddo
15895       do k=1,3
15896         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
15897          *sss_ele_cut
15898       enddo
15899 !      write (iout,*) "gg",(gg(k),k=1,3)
15900       do k=1,3
15901         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15902                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15903                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
15904                  *sss_ele_cut
15905         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15906                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15907                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
15908          *sss_ele_cut
15909 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
15910 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15911 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
15912 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15913       enddo
15914 !
15915 ! Calculate the components of the gradient in DC and X
15916 !
15917       do l=1,3
15918         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15919         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15920       enddo
15921       return
15922       end subroutine sc_grad_scale
15923 !-----------------------------------------------------------------------------
15924 ! energy_split-sep.F
15925 !-----------------------------------------------------------------------------
15926       subroutine etotal_long(energia)
15927 !
15928 ! Compute the long-range slow-varying contributions to the energy
15929 !
15930 !      implicit real*8 (a-h,o-z)
15931 !      include 'DIMENSIONS'
15932       use MD_data, only: totT,usampl,eq_time
15933 #ifndef ISNAN
15934       external proc_proc
15935 #ifdef WINPGI
15936 !MS$ATTRIBUTES C ::  proc_proc
15937 #endif
15938 #endif
15939 #ifdef MPI
15940       include "mpif.h"
15941       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
15942 #endif
15943 !      include 'COMMON.SETUP'
15944 !      include 'COMMON.IOUNITS'
15945 !      include 'COMMON.FFIELD'
15946 !      include 'COMMON.DERIV'
15947 !      include 'COMMON.INTERACT'
15948 !      include 'COMMON.SBRIDGE'
15949 !      include 'COMMON.CHAIN'
15950 !      include 'COMMON.VAR'
15951 !      include 'COMMON.LOCAL'
15952 !      include 'COMMON.MD'
15953       real(kind=8),dimension(0:n_ene) :: energia
15954 !el local variables
15955       integer :: i,n_corr,n_corr1,ierror,ierr
15956       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
15957                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
15958                   ecorr,ecorr5,ecorr6,eturn6,time00
15959 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
15960 !elwrite(iout,*)"in etotal long"
15961
15962       if (modecalc.eq.12.or.modecalc.eq.14) then
15963 #ifdef MPI
15964 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
15965 #else
15966         call int_from_cart1(.false.)
15967 #endif
15968       endif
15969 !elwrite(iout,*)"in etotal long"
15970
15971 #ifdef MPI
15972 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15973 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15974       call flush(iout)
15975       if (nfgtasks.gt.1) then
15976         time00=MPI_Wtime()
15977 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15978         if (fg_rank.eq.0) then
15979           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15980 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15981 !          call flush(iout)
15982 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15983 ! FG slaves as WEIGHTS array.
15984           weights_(1)=wsc
15985           weights_(2)=wscp
15986           weights_(3)=welec
15987           weights_(4)=wcorr
15988           weights_(5)=wcorr5
15989           weights_(6)=wcorr6
15990           weights_(7)=wel_loc
15991           weights_(8)=wturn3
15992           weights_(9)=wturn4
15993           weights_(10)=wturn6
15994           weights_(11)=wang
15995           weights_(12)=wscloc
15996           weights_(13)=wtor
15997           weights_(14)=wtor_d
15998           weights_(15)=wstrain
15999           weights_(16)=wvdwpp
16000           weights_(17)=wbond
16001           weights_(18)=scal14
16002           weights_(21)=wsccor
16003 ! FG Master broadcasts the WEIGHTS_ array
16004           call MPI_Bcast(weights_(1),n_ene,&
16005               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16006         else
16007 ! FG slaves receive the WEIGHTS array
16008           call MPI_Bcast(weights(1),n_ene,&
16009               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16010           wsc=weights(1)
16011           wscp=weights(2)
16012           welec=weights(3)
16013           wcorr=weights(4)
16014           wcorr5=weights(5)
16015           wcorr6=weights(6)
16016           wel_loc=weights(7)
16017           wturn3=weights(8)
16018           wturn4=weights(9)
16019           wturn6=weights(10)
16020           wang=weights(11)
16021           wscloc=weights(12)
16022           wtor=weights(13)
16023           wtor_d=weights(14)
16024           wstrain=weights(15)
16025           wvdwpp=weights(16)
16026           wbond=weights(17)
16027           scal14=weights(18)
16028           wsccor=weights(21)
16029         endif
16030         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
16031           king,FG_COMM,IERR)
16032          time_Bcast=time_Bcast+MPI_Wtime()-time00
16033          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
16034 !        call chainbuild_cart
16035 !        call int_from_cart1(.false.)
16036       endif
16037 !      write (iout,*) 'Processor',myrank,
16038 !     &  ' calling etotal_short ipot=',ipot
16039 !      call flush(iout)
16040 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16041 #endif
16042 !d    print *,'nnt=',nnt,' nct=',nct
16043 !
16044 !elwrite(iout,*)"in etotal long"
16045 ! Compute the side-chain and electrostatic interaction energy
16046 !
16047       goto (101,102,103,104,105,106) ipot
16048 ! Lennard-Jones potential.
16049   101 call elj_long(evdw)
16050 !d    print '(a)','Exit ELJ'
16051       goto 107
16052 ! Lennard-Jones-Kihara potential (shifted).
16053   102 call eljk_long(evdw)
16054       goto 107
16055 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16056   103 call ebp_long(evdw)
16057       goto 107
16058 ! Gay-Berne potential (shifted LJ, angular dependence).
16059   104 call egb_long(evdw)
16060       goto 107
16061 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16062   105 call egbv_long(evdw)
16063       goto 107
16064 ! Soft-sphere potential
16065   106 call e_softsphere(evdw)
16066 !
16067 ! Calculate electrostatic (H-bonding) energy of the main chain.
16068 !
16069   107 continue
16070       call vec_and_deriv
16071       if (ipot.lt.6) then
16072 #ifdef SPLITELE
16073          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
16074              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16075              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16076              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16077 #else
16078          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
16079              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16080              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16081              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16082 #endif
16083            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
16084          else
16085             ees=0
16086             evdw1=0
16087             eel_loc=0
16088             eello_turn3=0
16089             eello_turn4=0
16090          endif
16091       else
16092 !        write (iout,*) "Soft-spheer ELEC potential"
16093         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
16094          eello_turn4)
16095       endif
16096 !
16097 ! Calculate excluded-volume interaction energy between peptide groups
16098 ! and side chains.
16099 !
16100       if (ipot.lt.6) then
16101        if(wscp.gt.0d0) then
16102         call escp_long(evdw2,evdw2_14)
16103        else
16104         evdw2=0
16105         evdw2_14=0
16106        endif
16107       else
16108         call escp_soft_sphere(evdw2,evdw2_14)
16109       endif
16110 !
16111 ! 12/1/95 Multi-body terms
16112 !
16113       n_corr=0
16114       n_corr1=0
16115       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
16116           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
16117          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
16118 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
16119 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
16120       else
16121          ecorr=0.0d0
16122          ecorr5=0.0d0
16123          ecorr6=0.0d0
16124          eturn6=0.0d0
16125       endif
16126       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
16127          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
16128       endif
16129 !
16130 ! If performing constraint dynamics, call the constraint energy
16131 !  after the equilibration time
16132       if(usampl.and.totT.gt.eq_time) then
16133          call EconstrQ
16134          call Econstr_back
16135       else
16136          Uconst=0.0d0
16137          Uconst_back=0.0d0
16138       endif
16139 !
16140 ! Sum the energies
16141 !
16142       do i=1,n_ene
16143         energia(i)=0.0d0
16144       enddo
16145       energia(1)=evdw
16146 #ifdef SCP14
16147       energia(2)=evdw2-evdw2_14
16148       energia(18)=evdw2_14
16149 #else
16150       energia(2)=evdw2
16151       energia(18)=0.0d0
16152 #endif
16153 #ifdef SPLITELE
16154       energia(3)=ees
16155       energia(16)=evdw1
16156 #else
16157       energia(3)=ees+evdw1
16158       energia(16)=0.0d0
16159 #endif
16160       energia(4)=ecorr
16161       energia(5)=ecorr5
16162       energia(6)=ecorr6
16163       energia(7)=eel_loc
16164       energia(8)=eello_turn3
16165       energia(9)=eello_turn4
16166       energia(10)=eturn6
16167       energia(20)=Uconst+Uconst_back
16168       call sum_energy(energia,.true.)
16169 !      write (iout,*) "Exit ETOTAL_LONG"
16170       call flush(iout)
16171       return
16172       end subroutine etotal_long
16173 !-----------------------------------------------------------------------------
16174       subroutine etotal_short(energia)
16175 !
16176 ! Compute the short-range fast-varying contributions to the energy
16177 !
16178 !      implicit real*8 (a-h,o-z)
16179 !      include 'DIMENSIONS'
16180 #ifndef ISNAN
16181       external proc_proc
16182 #ifdef WINPGI
16183 !MS$ATTRIBUTES C ::  proc_proc
16184 #endif
16185 #endif
16186 #ifdef MPI
16187       include "mpif.h"
16188       integer :: ierror,ierr
16189       real(kind=8),dimension(n_ene) :: weights_
16190       real(kind=8) :: time00
16191 #endif
16192 !      include 'COMMON.SETUP'
16193 !      include 'COMMON.IOUNITS'
16194 !      include 'COMMON.FFIELD'
16195 !      include 'COMMON.DERIV'
16196 !      include 'COMMON.INTERACT'
16197 !      include 'COMMON.SBRIDGE'
16198 !      include 'COMMON.CHAIN'
16199 !      include 'COMMON.VAR'
16200 !      include 'COMMON.LOCAL'
16201       real(kind=8),dimension(0:n_ene) :: energia
16202 !el local variables
16203       integer :: i,nres6
16204       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
16205       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
16206       nres6=6*nres
16207
16208 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
16209 !      call flush(iout)
16210       if (modecalc.eq.12.or.modecalc.eq.14) then
16211 #ifdef MPI
16212         if (fg_rank.eq.0) call int_from_cart1(.false.)
16213 #else
16214         call int_from_cart1(.false.)
16215 #endif
16216       endif
16217 #ifdef MPI
16218 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
16219 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16220 !      call flush(iout)
16221       if (nfgtasks.gt.1) then
16222         time00=MPI_Wtime()
16223 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16224         if (fg_rank.eq.0) then
16225           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
16226 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16227 !          call flush(iout)
16228 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16229 ! FG slaves as WEIGHTS array.
16230           weights_(1)=wsc
16231           weights_(2)=wscp
16232           weights_(3)=welec
16233           weights_(4)=wcorr
16234           weights_(5)=wcorr5
16235           weights_(6)=wcorr6
16236           weights_(7)=wel_loc
16237           weights_(8)=wturn3
16238           weights_(9)=wturn4
16239           weights_(10)=wturn6
16240           weights_(11)=wang
16241           weights_(12)=wscloc
16242           weights_(13)=wtor
16243           weights_(14)=wtor_d
16244           weights_(15)=wstrain
16245           weights_(16)=wvdwpp
16246           weights_(17)=wbond
16247           weights_(18)=scal14
16248           weights_(21)=wsccor
16249 ! FG Master broadcasts the WEIGHTS_ array
16250           call MPI_Bcast(weights_(1),n_ene,&
16251               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16252         else
16253 ! FG slaves receive the WEIGHTS array
16254           call MPI_Bcast(weights(1),n_ene,&
16255               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16256           wsc=weights(1)
16257           wscp=weights(2)
16258           welec=weights(3)
16259           wcorr=weights(4)
16260           wcorr5=weights(5)
16261           wcorr6=weights(6)
16262           wel_loc=weights(7)
16263           wturn3=weights(8)
16264           wturn4=weights(9)
16265           wturn6=weights(10)
16266           wang=weights(11)
16267           wscloc=weights(12)
16268           wtor=weights(13)
16269           wtor_d=weights(14)
16270           wstrain=weights(15)
16271           wvdwpp=weights(16)
16272           wbond=weights(17)
16273           scal14=weights(18)
16274           wsccor=weights(21)
16275         endif
16276 !        write (iout,*),"Processor",myrank," BROADCAST weights"
16277         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
16278           king,FG_COMM,IERR)
16279 !        write (iout,*) "Processor",myrank," BROADCAST c"
16280         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
16281           king,FG_COMM,IERR)
16282 !        write (iout,*) "Processor",myrank," BROADCAST dc"
16283         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
16284           king,FG_COMM,IERR)
16285 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
16286         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
16287           king,FG_COMM,IERR)
16288 !        write (iout,*) "Processor",myrank," BROADCAST theta"
16289         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
16290           king,FG_COMM,IERR)
16291 !        write (iout,*) "Processor",myrank," BROADCAST phi"
16292         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
16293           king,FG_COMM,IERR)
16294 !        write (iout,*) "Processor",myrank," BROADCAST alph"
16295         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
16296           king,FG_COMM,IERR)
16297 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
16298         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
16299           king,FG_COMM,IERR)
16300 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
16301         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
16302           king,FG_COMM,IERR)
16303          time_Bcast=time_Bcast+MPI_Wtime()-time00
16304 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
16305       endif
16306 !      write (iout,*) 'Processor',myrank,
16307 !     &  ' calling etotal_short ipot=',ipot
16308 !      call flush(iout)
16309 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16310 #endif
16311 !      call int_from_cart1(.false.)
16312 !
16313 ! Compute the side-chain and electrostatic interaction energy
16314 !
16315       goto (101,102,103,104,105,106) ipot
16316 ! Lennard-Jones potential.
16317   101 call elj_short(evdw)
16318 !d    print '(a)','Exit ELJ'
16319       goto 107
16320 ! Lennard-Jones-Kihara potential (shifted).
16321   102 call eljk_short(evdw)
16322       goto 107
16323 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16324   103 call ebp_short(evdw)
16325       goto 107
16326 ! Gay-Berne potential (shifted LJ, angular dependence).
16327   104 call egb_short(evdw)
16328       goto 107
16329 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16330   105 call egbv_short(evdw)
16331       goto 107
16332 ! Soft-sphere potential - already dealt with in the long-range part
16333   106 evdw=0.0d0
16334 !  106 call e_softsphere_short(evdw)
16335 !
16336 ! Calculate electrostatic (H-bonding) energy of the main chain.
16337 !
16338   107 continue
16339 !
16340 ! Calculate the short-range part of Evdwpp
16341 !
16342       call evdwpp_short(evdw1)
16343 !
16344 ! Calculate the short-range part of ESCp
16345 !
16346       if (ipot.lt.6) then
16347        call escp_short(evdw2,evdw2_14)
16348       endif
16349 !
16350 ! Calculate the bond-stretching energy
16351 !
16352       call ebond(estr)
16353 !
16354 ! Calculate the disulfide-bridge and other energy and the contributions
16355 ! from other distance constraints.
16356       call edis(ehpb)
16357 !
16358 ! Calculate the virtual-bond-angle energy.
16359 !
16360 ! Calculate the SC local energy.
16361 !
16362       call vec_and_deriv
16363       call esc(escloc)
16364 !
16365       if (wang.gt.0d0) then
16366        if (tor_mode.eq.0) then
16367            call ebend(ebe)
16368        else
16369 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
16370 !C energy function
16371         call ebend_kcc(ebe)
16372        endif
16373       else
16374           ebe=0.0d0
16375       endif
16376       ethetacnstr=0.0d0
16377       if (with_theta_constr) call etheta_constr(ethetacnstr)
16378
16379 !       write(iout,*) "in etotal afer ebe",ipot
16380
16381 !      print *,"Processor",myrank," computed UB"
16382 !
16383 ! Calculate the SC local energy.
16384 !
16385       call esc(escloc)
16386 !elwrite(iout,*) "in etotal afer esc",ipot
16387 !      print *,"Processor",myrank," computed USC"
16388 !
16389 ! Calculate the virtual-bond torsional energy.
16390 !
16391 !d    print *,'nterm=',nterm
16392 !      if (wtor.gt.0) then
16393 !       call etor(etors,edihcnstr)
16394 !      else
16395 !       etors=0
16396 !       edihcnstr=0
16397 !      endif
16398       if (wtor.gt.0.0d0) then
16399          if (tor_mode.eq.0) then
16400            call etor(etors)
16401           else
16402 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
16403 !C energy function
16404         call etor_kcc(etors)
16405          endif
16406       else
16407            etors=0.0d0
16408       endif
16409       edihcnstr=0.0d0
16410       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
16411
16412 ! Calculate the virtual-bond torsional energy.
16413 !
16414 !
16415 ! 6/23/01 Calculate double-torsional energy
16416 !
16417       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
16418       call etor_d(etors_d)
16419       endif
16420 !
16421 ! 21/5/07 Calculate local sicdechain correlation energy
16422 !
16423       if (wsccor.gt.0.0d0) then
16424        call eback_sc_corr(esccor)
16425       else
16426        esccor=0.0d0
16427       endif
16428 !
16429 ! Put energy components into an array
16430 !
16431       do i=1,n_ene
16432        energia(i)=0.0d0
16433       enddo
16434       energia(1)=evdw
16435 #ifdef SCP14
16436       energia(2)=evdw2-evdw2_14
16437       energia(18)=evdw2_14
16438 #else
16439       energia(2)=evdw2
16440       energia(18)=0.0d0
16441 #endif
16442 #ifdef SPLITELE
16443       energia(16)=evdw1
16444 #else
16445       energia(3)=evdw1
16446 #endif
16447       energia(11)=ebe
16448       energia(12)=escloc
16449       energia(13)=etors
16450       energia(14)=etors_d
16451       energia(15)=ehpb
16452       energia(17)=estr
16453       energia(19)=edihcnstr
16454       energia(21)=esccor
16455 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
16456       call flush(iout)
16457       call sum_energy(energia,.true.)
16458 !      write (iout,*) "Exit ETOTAL_SHORT"
16459       call flush(iout)
16460       return
16461       end subroutine etotal_short
16462 !-----------------------------------------------------------------------------
16463 ! gnmr1.f
16464 !-----------------------------------------------------------------------------
16465       real(kind=8) function gnmr1(y,ymin,ymax)
16466 !      implicit none
16467       real(kind=8) :: y,ymin,ymax
16468       real(kind=8) :: wykl=4.0d0
16469       if (y.lt.ymin) then
16470         gnmr1=(ymin-y)**wykl/wykl
16471       else if (y.gt.ymax) then
16472        gnmr1=(y-ymax)**wykl/wykl
16473       else
16474        gnmr1=0.0d0
16475       endif
16476       return
16477       end function gnmr1
16478 !-----------------------------------------------------------------------------
16479       real(kind=8) function gnmr1prim(y,ymin,ymax)
16480 !      implicit none
16481       real(kind=8) :: y,ymin,ymax
16482       real(kind=8) :: wykl=4.0d0
16483       if (y.lt.ymin) then
16484        gnmr1prim=-(ymin-y)**(wykl-1)
16485       else if (y.gt.ymax) then
16486        gnmr1prim=(y-ymax)**(wykl-1)
16487       else
16488        gnmr1prim=0.0d0
16489       endif
16490       return
16491       end function gnmr1prim
16492 !----------------------------------------------------------------------------
16493       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
16494       real(kind=8) y,ymin,ymax,sigma
16495       real(kind=8) wykl /4.0d0/
16496       if (y.lt.ymin) then
16497         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
16498       else if (y.gt.ymax) then
16499        rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
16500       else
16501         rlornmr1=0.0d0
16502       endif
16503       return
16504       end function rlornmr1
16505 !------------------------------------------------------------------------------
16506       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
16507       real(kind=8) y,ymin,ymax,sigma
16508       real(kind=8) wykl /4.0d0/
16509       if (y.lt.ymin) then
16510         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
16511         ((ymin-y)**wykl+sigma**wykl)**2
16512       else if (y.gt.ymax) then
16513          rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
16514         ((y-ymax)**wykl+sigma**wykl)**2
16515       else
16516        rlornmr1prim=0.0d0
16517       endif
16518       return
16519       end function rlornmr1prim
16520
16521       real(kind=8) function harmonic(y,ymax)
16522 !      implicit none
16523       real(kind=8) :: y,ymax
16524       real(kind=8) :: wykl=2.0d0
16525       harmonic=(y-ymax)**wykl
16526       return
16527       end function harmonic
16528 !-----------------------------------------------------------------------------
16529       real(kind=8) function harmonicprim(y,ymax)
16530       real(kind=8) :: y,ymin,ymax
16531       real(kind=8) :: wykl=2.0d0
16532       harmonicprim=(y-ymax)*wykl
16533       return
16534       end function harmonicprim
16535 !-----------------------------------------------------------------------------
16536 ! gradient_p.F
16537 !-----------------------------------------------------------------------------
16538       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
16539
16540       use io_base, only:intout,briefout
16541 !      implicit real*8 (a-h,o-z)
16542 !      include 'DIMENSIONS'
16543 !      include 'COMMON.CHAIN'
16544 !      include 'COMMON.DERIV'
16545 !      include 'COMMON.VAR'
16546 !      include 'COMMON.INTERACT'
16547 !      include 'COMMON.FFIELD'
16548 !      include 'COMMON.MD'
16549 !      include 'COMMON.IOUNITS'
16550       real(kind=8),external :: ufparm
16551       integer :: uiparm(1)
16552       real(kind=8) :: urparm(1)
16553       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
16554       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
16555       integer :: n,nf,ind,ind1,i,k,j
16556 !
16557 ! This subroutine calculates total internal coordinate gradient.
16558 ! Depending on the number of function evaluations, either whole energy
16559 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
16560 ! internal coordinates are reevaluated or only the cartesian-in-internal
16561 ! coordinate derivatives are evaluated. The subroutine was designed to work
16562 ! with SUMSL.
16563 !
16564 !
16565       icg=mod(nf,2)+1
16566
16567 !d      print *,'grad',nf,icg
16568       if (nf-nfl+1) 20,30,40
16569    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
16570 !    write (iout,*) 'grad 20'
16571       if (nf.eq.0) return
16572       goto 40
16573    30 call var_to_geom(n,x)
16574       call chainbuild
16575 !    write (iout,*) 'grad 30'
16576 !
16577 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
16578 !
16579    40 call cartder
16580 !     write (iout,*) 'grad 40'
16581 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
16582 !
16583 ! Convert the Cartesian gradient into internal-coordinate gradient.
16584 !
16585       ind=0
16586       ind1=0
16587       do i=1,nres-2
16588       gthetai=0.0D0
16589       gphii=0.0D0
16590       do j=i+1,nres-1
16591         ind=ind+1
16592 !         ind=indmat(i,j)
16593 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16594        do k=1,3
16595        gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
16596         enddo
16597         do k=1,3
16598         gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
16599          enddo
16600        enddo
16601       do j=i+1,nres-1
16602         ind1=ind1+1
16603 !         ind1=indmat(i,j)
16604 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
16605         do k=1,3
16606           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
16607           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
16608           enddo
16609         enddo
16610       if (i.gt.1) g(i-1)=gphii
16611       if (n.gt.nphi) g(nphi+i)=gthetai
16612       enddo
16613       if (n.le.nphi+ntheta) goto 10
16614       do i=2,nres-1
16615       if (itype(i,1).ne.10) then
16616           galphai=0.0D0
16617         gomegai=0.0D0
16618         do k=1,3
16619           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
16620           enddo
16621         do k=1,3
16622           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
16623           enddo
16624           g(ialph(i,1))=galphai
16625         g(ialph(i,1)+nside)=gomegai
16626         endif
16627       enddo
16628 !
16629 ! Add the components corresponding to local energy terms.
16630 !
16631    10 continue
16632       do i=1,nvar
16633 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
16634         g(i)=g(i)+gloc(i,icg)
16635       enddo
16636 ! Uncomment following three lines for diagnostics.
16637 !d    call intout
16638 !elwrite(iout,*) "in gradient after calling intout"
16639 !d    call briefout(0,0.0d0)
16640 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
16641       return
16642       end subroutine gradient
16643 !-----------------------------------------------------------------------------
16644       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
16645
16646       use comm_chu
16647 !      implicit real*8 (a-h,o-z)
16648 !      include 'DIMENSIONS'
16649 !      include 'COMMON.DERIV'
16650 !      include 'COMMON.IOUNITS'
16651 !      include 'COMMON.GEO'
16652       integer :: n,nf
16653 !el      integer :: jjj
16654 !el      common /chuju/ jjj
16655       real(kind=8) :: energia(0:n_ene)
16656       integer :: uiparm(1)
16657       real(kind=8) :: urparm(1)
16658       real(kind=8) :: f
16659       real(kind=8),external :: ufparm
16660       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
16661 !     if (jjj.gt.0) then
16662 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16663 !     endif
16664       nfl=nf
16665       icg=mod(nf,2)+1
16666 !d      print *,'func',nf,nfl,icg
16667       call var_to_geom(n,x)
16668       call zerograd
16669       call chainbuild
16670 !d    write (iout,*) 'ETOTAL called from FUNC'
16671       call etotal(energia)
16672       call sum_gradient
16673       f=energia(0)
16674 !     if (jjj.gt.0) then
16675 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16676 !       write (iout,*) 'f=',etot
16677 !       jjj=0
16678 !     endif
16679       return
16680       end subroutine func
16681 !-----------------------------------------------------------------------------
16682       subroutine cartgrad
16683 !      implicit real*8 (a-h,o-z)
16684 !      include 'DIMENSIONS'
16685       use energy_data
16686       use MD_data, only: totT,usampl,eq_time
16687 #ifdef MPI
16688       include 'mpif.h'
16689 #endif
16690 !      include 'COMMON.CHAIN'
16691 !      include 'COMMON.DERIV'
16692 !      include 'COMMON.VAR'
16693 !      include 'COMMON.INTERACT'
16694 !      include 'COMMON.FFIELD'
16695 !      include 'COMMON.MD'
16696 !      include 'COMMON.IOUNITS'
16697 !      include 'COMMON.TIME1'
16698 !
16699       integer :: i,j
16700       real(kind=8) :: time00,time01
16701
16702 ! This subrouting calculates total Cartesian coordinate gradient.
16703 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
16704 !
16705 !#define DEBUG
16706 #ifdef TIMINGtime01
16707       time00=MPI_Wtime()
16708 #endif
16709       icg=1
16710       call sum_gradient
16711 #ifdef TIMING
16712 #endif
16713 !#define DEBUG
16714 !el      write (iout,*) "After sum_gradient"
16715 #ifdef DEBUG
16716       write (iout,*) "After sum_gradient"
16717       do i=1,nres-1
16718         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
16719         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
16720       enddo
16721 #endif
16722 !#undef DEBUG
16723 ! If performing constraint dynamics, add the gradients of the constraint energy
16724       if(usampl.and.totT.gt.eq_time) then
16725          do i=1,nct
16726            do j=1,3
16727              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
16728              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
16729            enddo
16730          enddo
16731          do i=1,nres-3
16732            gloc(i,icg)=gloc(i,icg)+dugamma(i)
16733          enddo
16734          do i=1,nres-2
16735            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
16736          enddo
16737       endif
16738 !elwrite (iout,*) "After sum_gradient"
16739 #ifdef TIMING
16740       time01=MPI_Wtime()
16741 #endif
16742       call intcartderiv
16743 !elwrite (iout,*) "After sum_gradient"
16744 #ifdef TIMING
16745       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
16746 #endif
16747 !     call checkintcartgrad
16748 !     write(iout,*) 'calling int_to_cart'
16749 !#define DEBUG
16750 #ifdef DEBUG
16751       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
16752 #endif
16753       do i=0,nct
16754         do j=1,3
16755           gcart(j,i)=gradc(j,i,icg)
16756           gxcart(j,i)=gradx(j,i,icg)
16757 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
16758         enddo
16759 #ifdef DEBUG
16760         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
16761           (gxcart(j,i),j=1,3),gloc(i,icg)
16762 #endif
16763       enddo
16764 #ifdef TIMING
16765       time01=MPI_Wtime()
16766 #endif
16767 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16768       call int_to_cart
16769 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16770
16771 #ifdef TIMING
16772             time_inttocart=time_inttocart+MPI_Wtime()-time01
16773 #endif
16774 #ifdef DEBUG
16775             write (iout,*) "gcart and gxcart after int_to_cart"
16776             do i=0,nres-1
16777             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
16778             (gxcart(j,i),j=1,3)
16779             enddo
16780 #endif
16781 !#undef DEBUG
16782 #ifdef CARGRAD
16783 #ifdef DEBUG
16784             write (iout,*) "CARGRAD"
16785 #endif
16786             do i=nres,0,-1
16787             do j=1,3
16788               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16789       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16790             enddo
16791       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
16792       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
16793             enddo
16794       ! Correction: dummy residues
16795             if (nnt.gt.1) then
16796               do j=1,3
16797       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
16798             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
16799             enddo
16800           endif
16801           if (nct.lt.nres) then
16802             do j=1,3
16803       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
16804             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
16805             enddo
16806           endif
16807 #endif
16808 #ifdef TIMING
16809           time_cartgrad=time_cartgrad+MPI_Wtime()-time00
16810 #endif
16811 !#undef DEBUG
16812           return
16813           end subroutine cartgrad
16814       !-----------------------------------------------------------------------------
16815           subroutine zerograd
16816       !      implicit real*8 (a-h,o-z)
16817       !      include 'DIMENSIONS'
16818       !      include 'COMMON.DERIV'
16819       !      include 'COMMON.CHAIN'
16820       !      include 'COMMON.VAR'
16821       !      include 'COMMON.MD'
16822       !      include 'COMMON.SCCOR'
16823       !
16824       !el local variables
16825           integer :: i,j,intertyp,k
16826       ! Initialize Cartesian-coordinate gradient
16827       !
16828       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
16829       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
16830
16831       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
16832       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
16833       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
16834       !      allocate(gradcorr_long(3,nres))
16835       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
16836       !      allocate(gcorr6_turn_long(3,nres))
16837       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
16838
16839       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
16840
16841       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
16842       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
16843
16844       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
16845       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
16846
16847       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
16848       !      allocate(gscloc(3,nres)) !(3,maxres)
16849       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
16850
16851
16852
16853       !      common /deriv_scloc/
16854       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
16855       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
16856       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
16857       !      common /mpgrad/
16858       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
16859
16860
16861
16862       !          gradc(j,i,icg)=0.0d0
16863       !          gradx(j,i,icg)=0.0d0
16864
16865       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
16866       !elwrite(iout,*) "icg",icg
16867           do i=-1,nres
16868           do j=1,3
16869             gvdwx(j,i)=0.0D0
16870             gradx_scp(j,i)=0.0D0
16871             gvdwc(j,i)=0.0D0
16872             gvdwc_scp(j,i)=0.0D0
16873             gvdwc_scpp(j,i)=0.0d0
16874             gelc(j,i)=0.0D0
16875             gelc_long(j,i)=0.0D0
16876             gradb(j,i)=0.0d0
16877             gradbx(j,i)=0.0d0
16878             gvdwpp(j,i)=0.0d0
16879             gel_loc(j,i)=0.0d0
16880             gel_loc_long(j,i)=0.0d0
16881             ghpbc(j,i)=0.0D0
16882             ghpbx(j,i)=0.0D0
16883             gcorr3_turn(j,i)=0.0d0
16884             gcorr4_turn(j,i)=0.0d0
16885             gradcorr(j,i)=0.0d0
16886             gradcorr_long(j,i)=0.0d0
16887             gradcorr5_long(j,i)=0.0d0
16888             gradcorr6_long(j,i)=0.0d0
16889             gcorr6_turn_long(j,i)=0.0d0
16890             gradcorr5(j,i)=0.0d0
16891             gradcorr6(j,i)=0.0d0
16892             gcorr6_turn(j,i)=0.0d0
16893             gsccorc(j,i)=0.0d0
16894             gsccorx(j,i)=0.0d0
16895             gradc(j,i,icg)=0.0d0
16896             gradx(j,i,icg)=0.0d0
16897             gscloc(j,i)=0.0d0
16898             gsclocx(j,i)=0.0d0
16899             gliptran(j,i)=0.0d0
16900             gliptranx(j,i)=0.0d0
16901             gliptranc(j,i)=0.0d0
16902             gshieldx(j,i)=0.0d0
16903             gshieldc(j,i)=0.0d0
16904             gshieldc_loc(j,i)=0.0d0
16905             gshieldx_ec(j,i)=0.0d0
16906             gshieldc_ec(j,i)=0.0d0
16907             gshieldc_loc_ec(j,i)=0.0d0
16908             gshieldx_t3(j,i)=0.0d0
16909             gshieldc_t3(j,i)=0.0d0
16910             gshieldc_loc_t3(j,i)=0.0d0
16911             gshieldx_t4(j,i)=0.0d0
16912             gshieldc_t4(j,i)=0.0d0
16913             gshieldc_loc_t4(j,i)=0.0d0
16914             gshieldx_ll(j,i)=0.0d0
16915             gshieldc_ll(j,i)=0.0d0
16916             gshieldc_loc_ll(j,i)=0.0d0
16917             gg_tube(j,i)=0.0d0
16918             gg_tube_sc(j,i)=0.0d0
16919             gradafm(j,i)=0.0d0
16920             gradb_nucl(j,i)=0.0d0
16921             gradbx_nucl(j,i)=0.0d0
16922             gvdwpp_nucl(j,i)=0.0d0
16923             gvdwpp(j,i)=0.0d0
16924             gelpp(j,i)=0.0d0
16925             gvdwpsb(j,i)=0.0d0
16926             gvdwpsb1(j,i)=0.0d0
16927             gvdwsbc(j,i)=0.0d0
16928             gvdwsbx(j,i)=0.0d0
16929             gelsbc(j,i)=0.0d0
16930             gradcorr_nucl(j,i)=0.0d0
16931             gradcorr3_nucl(j,i)=0.0d0
16932             gradxorr_nucl(j,i)=0.0d0
16933             gradxorr3_nucl(j,i)=0.0d0
16934             gelsbx(j,i)=0.0d0
16935             gsbloc(j,i)=0.0d0
16936             gsblocx(j,i)=0.0d0
16937             gradpepcat(j,i)=0.0d0
16938             gradpepcatx(j,i)=0.0d0
16939             gradcatcat(j,i)=0.0d0
16940             gvdwx_scbase(j,i)=0.0d0
16941             gvdwc_scbase(j,i)=0.0d0
16942             gvdwx_pepbase(j,i)=0.0d0
16943             gvdwc_pepbase(j,i)=0.0d0
16944             gvdwx_scpho(j,i)=0.0d0
16945             gvdwc_scpho(j,i)=0.0d0
16946             gvdwc_peppho(j,i)=0.0d0
16947             gradnuclcatx(j,i)=0.0d0
16948             gradnuclcat(j,i)=0.0d0
16949           enddo
16950            enddo
16951           do i=0,nres
16952           do j=1,3
16953             do intertyp=1,3
16954              gloc_sc(intertyp,i,icg)=0.0d0
16955             enddo
16956           enddo
16957           enddo
16958           do i=1,nres
16959            do j=1,maxcontsshi
16960            shield_list(j,i)=0
16961           do k=1,3
16962       !C           print *,i,j,k
16963              grad_shield_side(k,j,i)=0.0d0
16964              grad_shield_loc(k,j,i)=0.0d0
16965            enddo
16966            enddo
16967            ishield_list(i)=0
16968           enddo
16969
16970       !
16971       ! Initialize the gradient of local energy terms.
16972       !
16973       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
16974       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
16975       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
16976       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
16977       !      allocate(gel_loc_turn3(nres))
16978       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
16979       !      allocate(gsccor_loc(nres))      !(maxres)
16980
16981           do i=1,4*nres
16982           gloc(i,icg)=0.0D0
16983           enddo
16984           do i=1,nres
16985           gel_loc_loc(i)=0.0d0
16986           gcorr_loc(i)=0.0d0
16987           g_corr5_loc(i)=0.0d0
16988           g_corr6_loc(i)=0.0d0
16989           gel_loc_turn3(i)=0.0d0
16990           gel_loc_turn4(i)=0.0d0
16991           gel_loc_turn6(i)=0.0d0
16992           gsccor_loc(i)=0.0d0
16993           enddo
16994       ! initialize gcart and gxcart
16995       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
16996           do i=0,nres
16997           do j=1,3
16998             gcart(j,i)=0.0d0
16999             gxcart(j,i)=0.0d0
17000           enddo
17001           enddo
17002           return
17003           end subroutine zerograd
17004       !-----------------------------------------------------------------------------
17005           real(kind=8) function fdum()
17006           fdum=0.0D0
17007           return
17008           end function fdum
17009       !-----------------------------------------------------------------------------
17010       ! intcartderiv.F
17011       !-----------------------------------------------------------------------------
17012           subroutine intcartderiv
17013       !      implicit real*8 (a-h,o-z)
17014       !      include 'DIMENSIONS'
17015 #ifdef MPI
17016           include 'mpif.h'
17017 #endif
17018       !      include 'COMMON.SETUP'
17019       !      include 'COMMON.CHAIN'
17020       !      include 'COMMON.VAR'
17021       !      include 'COMMON.GEO'
17022       !      include 'COMMON.INTERACT'
17023       !      include 'COMMON.DERIV'
17024       !      include 'COMMON.IOUNITS'
17025       !      include 'COMMON.LOCAL'
17026       !      include 'COMMON.SCCOR'
17027           real(kind=8) :: pi4,pi34
17028           real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
17029           real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
17030                   dcosomega,dsinomega !(3,3,maxres)
17031           real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
17032
17033           integer :: i,j,k
17034           real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
17035                 fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
17036                 fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
17037                 fac17,coso_inv,fac10,fac11,fac12,fac13,fac14,IERROR
17038           integer :: nres2
17039           nres2=2*nres
17040
17041       !el from module energy-------------
17042       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
17043       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
17044       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
17045
17046       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
17047       !el      allocate(dsintau(3,3,3,0:nres2))
17048       !el      allocate(dtauangle(3,3,3,0:nres2))
17049       !el      allocate(domicron(3,2,2,0:nres2))
17050       !el      allocate(dcosomicron(3,2,2,0:nres2))
17051
17052
17053
17054 #if defined(MPI) && defined(PARINTDER)
17055           if (nfgtasks.gt.1 .and. me.eq.king) &
17056           call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
17057 #endif
17058           pi4 = 0.5d0*pipol
17059           pi34 = 3*pi4
17060
17061       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
17062       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
17063
17064       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
17065           do i=1,nres
17066           do j=1,3
17067             dtheta(j,1,i)=0.0d0
17068             dtheta(j,2,i)=0.0d0
17069             dphi(j,1,i)=0.0d0
17070             dphi(j,2,i)=0.0d0
17071             dphi(j,3,i)=0.0d0
17072             dcosomicron(j,1,1,i)=0.0d0
17073             dcosomicron(j,1,2,i)=0.0d0
17074             dcosomicron(j,2,1,i)=0.0d0
17075             dcosomicron(j,2,2,i)=0.0d0
17076           enddo
17077           enddo
17078       ! Derivatives of theta's
17079 #if defined(MPI) && defined(PARINTDER)
17080       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17081           do i=max0(ithet_start-1,3),ithet_end
17082 #else
17083           do i=3,nres
17084 #endif
17085           cost=dcos(theta(i))
17086           sint=sqrt(1-cost*cost)
17087           do j=1,3
17088             dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
17089             vbld(i-1)
17090             if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
17091             dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
17092             vbld(i)
17093             if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
17094           enddo
17095           enddo
17096 #if defined(MPI) && defined(PARINTDER)
17097       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17098           do i=max0(ithet_start-1,3),ithet_end
17099 #else
17100           do i=3,nres
17101 #endif
17102           if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1).and.molnum(i).ne.5) then
17103           cost1=dcos(omicron(1,i))
17104           sint1=sqrt(1-cost1*cost1)
17105           cost2=dcos(omicron(2,i))
17106           sint2=sqrt(1-cost2*cost2)
17107            do j=1,3
17108       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
17109             dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
17110             cost1*dc_norm(j,i-2))/ &
17111             vbld(i-1)
17112             domicron(j,1,1,i)=-1.0/sint1*dcosomicron(j,1,1,i)
17113             dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
17114             +cost1*(dc_norm(j,i-1+nres)))/ &
17115             vbld(i-1+nres)
17116             domicron(j,1,2,i)=-1.0/sint1*dcosomicron(j,1,2,i)
17117       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
17118       !C Looks messy but better than if in loop
17119             dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
17120             +cost2*dc_norm(j,i-1))/ &
17121             vbld(i)
17122             domicron(j,2,1,i)=-1.0/sint2*dcosomicron(j,2,1,i)
17123             dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
17124              +cost2*(-dc_norm(j,i-1+nres)))/ &
17125             vbld(i-1+nres)
17126       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
17127             domicron(j,2,2,i)=-1.0/sint2*dcosomicron(j,2,2,i)
17128           enddo
17129            endif
17130           enddo
17131       !elwrite(iout,*) "after vbld write"
17132       ! Derivatives of phi:
17133       ! If phi is 0 or 180 degrees, then the formulas
17134       ! have to be derived by power series expansion of the
17135       ! conventional formulas around 0 and 180.
17136 #ifdef PARINTDER
17137           do i=iphi1_start,iphi1_end
17138 #else
17139           do i=4,nres
17140 #endif
17141       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
17142       ! the conventional case
17143           sint=dsin(theta(i))
17144           sint1=dsin(theta(i-1))
17145           sing=dsin(phi(i))
17146           cost=dcos(theta(i))
17147           cost1=dcos(theta(i-1))
17148           cosg=dcos(phi(i))
17149           scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
17150           fac0=1.0d0/(sint1*sint)
17151           fac1=cost*fac0
17152           fac2=cost1*fac0
17153           fac3=cosg*cost1/(sint1*sint1)
17154           fac4=cosg*cost/(sint*sint)
17155       !    Obtaining the gamma derivatives from sine derivative
17156            if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
17157              phi(i).gt.pi34.and.phi(i).le.pi.or. &
17158              phi(i).ge.-pi.and.phi(i).le.-pi34) then
17159            call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17160            call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
17161            call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17162            do j=1,3
17163             ctgt=cost/sint
17164             ctgt1=cost1/sint1
17165             cosg_inv=1.0d0/cosg
17166             if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17167             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17168               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
17169             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
17170             dsinphi(j,2,i)= &
17171               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
17172               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17173             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
17174             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
17175               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17176       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17177             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
17178             endif
17179       ! Bug fixed 3/24/05 (AL)
17180            enddo
17181       !   Obtaining the gamma derivatives from cosine derivative
17182           else
17183              do j=1,3
17184              if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17185              dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17186              dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17187              dc_norm(j,i-3))/vbld(i-2)
17188              dphi(j,1,i)=-1.0/sing*dcosphi(j,1,i)
17189              dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17190              dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17191              dcostheta(j,1,i)
17192              dphi(j,2,i)=-1.0/sing*dcosphi(j,2,i)
17193              dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17194              dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17195              dc_norm(j,i-1))/vbld(i)
17196              dphi(j,3,i)=-1.0/sing*dcosphi(j,3,i)
17197 !#define DEBUG
17198 #ifdef DEBUG
17199              write(iout,*) "just after",dphi(j,3,i),sing,dcosphi(j,3,i)
17200 #endif
17201 !#undef DEBUG
17202              endif
17203            enddo
17204           endif
17205           enddo
17206       !alculate derivative of Tauangle
17207 #ifdef PARINTDER
17208           do i=itau_start,itau_end
17209 #else
17210           do i=3,nres
17211       !elwrite(iout,*) " vecpr",i,nres
17212 #endif
17213            if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17214       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
17215       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
17216       !c dtauangle(j,intertyp,dervityp,residue number)
17217       !c INTERTYP=1 SC...Ca...Ca..Ca
17218       ! the conventional case
17219           sint=dsin(theta(i))
17220           sint1=dsin(omicron(2,i-1))
17221           sing=dsin(tauangle(1,i))
17222           cost=dcos(theta(i))
17223           cost1=dcos(omicron(2,i-1))
17224           cosg=dcos(tauangle(1,i))
17225       !elwrite(iout,*) " vecpr5",i,nres
17226           do j=1,3
17227       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
17228       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
17229           dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17230       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
17231           enddo
17232           scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
17233           fac0=1.0d0/(sint1*sint)
17234           fac1=cost*fac0
17235           fac2=cost1*fac0
17236           fac3=cosg*cost1/(sint1*sint1)
17237           fac4=cosg*cost/(sint*sint)
17238       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
17239       !    Obtaining the gamma derivatives from sine derivative
17240            if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
17241              tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
17242              tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
17243            call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17244            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
17245            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17246           do j=1,3
17247             ctgt=cost/sint
17248             ctgt1=cost1/sint1
17249             cosg_inv=1.0d0/cosg
17250             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17251            -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
17252            *vbld_inv(i-2+nres)
17253             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
17254             dsintau(j,1,2,i)= &
17255               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
17256               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17257       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
17258             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
17259       ! Bug fixed 3/24/05 (AL)
17260             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
17261               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17262       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17263             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
17264            enddo
17265       !   Obtaining the gamma derivatives from cosine derivative
17266           else
17267              do j=1,3
17268              dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17269              dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17270              (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
17271              dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
17272              dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17273              dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17274              dcostheta(j,1,i)
17275              dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
17276              dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17277              dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
17278              dc_norm(j,i-1))/vbld(i)
17279              dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
17280       !         write (iout,*) "else",i
17281            enddo
17282           endif
17283       !        do k=1,3
17284       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
17285       !        enddo
17286           enddo
17287       !C Second case Ca...Ca...Ca...SC
17288 #ifdef PARINTDER
17289           do i=itau_start,itau_end
17290 #else
17291           do i=4,nres
17292 #endif
17293            if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17294             (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
17295       ! the conventional case
17296           sint=dsin(omicron(1,i))
17297           sint1=dsin(theta(i-1))
17298           sing=dsin(tauangle(2,i))
17299           cost=dcos(omicron(1,i))
17300           cost1=dcos(theta(i-1))
17301           cosg=dcos(tauangle(2,i))
17302       !        do j=1,3
17303       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17304       !        enddo
17305           scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
17306           fac0=1.0d0/(sint1*sint)
17307           fac1=cost*fac0
17308           fac2=cost1*fac0
17309           fac3=cosg*cost1/(sint1*sint1)
17310           fac4=cosg*cost/(sint*sint)
17311       !    Obtaining the gamma derivatives from sine derivative
17312            if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
17313              tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
17314              tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
17315            call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
17316            call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
17317            call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17318           do j=1,3
17319             ctgt=cost/sint
17320             ctgt1=cost1/sint1
17321             cosg_inv=1.0d0/cosg
17322             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17323               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
17324       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
17325       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
17326             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
17327             dsintau(j,2,2,i)= &
17328               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
17329               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17330       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
17331       !     & sing*ctgt*domicron(j,1,2,i),
17332       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17333             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
17334       ! Bug fixed 3/24/05 (AL)
17335             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17336              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
17337       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17338             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
17339            enddo
17340       !   Obtaining the gamma derivatives from cosine derivative
17341           else
17342              do j=1,3
17343              dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17344              dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17345              dc_norm(j,i-3))/vbld(i-2)
17346              dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
17347              dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17348              dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17349              dcosomicron(j,1,1,i)
17350              dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
17351              dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17352              dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17353              dc_norm(j,i-1+nres))/vbld(i-1+nres)
17354              dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
17355       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
17356            enddo
17357           endif
17358           enddo
17359
17360       !CC third case SC...Ca...Ca...SC
17361 #ifdef PARINTDER
17362
17363           do i=itau_start,itau_end
17364 #else
17365           do i=3,nres
17366 #endif
17367       ! the conventional case
17368           if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17369           (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17370           sint=dsin(omicron(1,i))
17371           sint1=dsin(omicron(2,i-1))
17372           sing=dsin(tauangle(3,i))
17373           cost=dcos(omicron(1,i))
17374           cost1=dcos(omicron(2,i-1))
17375           cosg=dcos(tauangle(3,i))
17376           do j=1,3
17377           dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17378       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17379           enddo
17380           scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
17381           fac0=1.0d0/(sint1*sint)
17382           fac1=cost*fac0
17383           fac2=cost1*fac0
17384           fac3=cosg*cost1/(sint1*sint1)
17385           fac4=cosg*cost/(sint*sint)
17386       !    Obtaining the gamma derivatives from sine derivative
17387            if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
17388              tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
17389              tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
17390            call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
17391            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
17392            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17393           do j=1,3
17394             ctgt=cost/sint
17395             ctgt1=cost1/sint1
17396             cosg_inv=1.0d0/cosg
17397             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17398               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
17399               *vbld_inv(i-2+nres)
17400             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
17401             dsintau(j,3,2,i)= &
17402               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
17403               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17404             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
17405       ! Bug fixed 3/24/05 (AL)
17406             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17407               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
17408               *vbld_inv(i-1+nres)
17409       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17410             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
17411            enddo
17412       !   Obtaining the gamma derivatives from cosine derivative
17413           else
17414              do j=1,3
17415              dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17416              dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17417              dc_norm2(j,i-2+nres))/vbld(i-2+nres)
17418              dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
17419              dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17420              dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17421              dcosomicron(j,1,1,i)
17422              dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
17423              dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17424              dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
17425              dc_norm(j,i-1+nres))/vbld(i-1+nres)
17426              dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
17427       !          write(iout,*) "else",i
17428            enddo
17429           endif
17430           enddo
17431
17432 #ifdef CRYST_SC
17433       !   Derivatives of side-chain angles alpha and omega
17434 #if defined(MPI) && defined(PARINTDER)
17435           do i=ibond_start,ibond_end
17436 #else
17437           do i=2,nres-1
17438 #endif
17439             if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
17440              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
17441              fac6=fac5/vbld(i)
17442              fac7=fac5*fac5
17443              fac8=fac5/vbld(i+1)
17444              fac9=fac5/vbld(i+nres)
17445              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
17446              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
17447              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
17448              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
17449              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
17450              sina=sqrt(1-cosa*cosa)
17451              sino=dsin(omeg(i))
17452       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
17453              do j=1,3
17454               dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
17455               dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
17456               dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
17457               dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
17458               scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
17459               dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
17460               dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
17461               dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
17462               vbld(i+nres))
17463               dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
17464             enddo
17465       ! obtaining the derivatives of omega from sines
17466             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
17467                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
17468                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
17469                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
17470                dsin(theta(i+1)))
17471                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
17472                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
17473                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
17474                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
17475                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
17476                coso_inv=1.0d0/dcos(omeg(i))
17477                do j=1,3
17478                dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
17479                +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
17480                (sino*dc_norm(j,i-1))/vbld(i)
17481                domega(j,1,i)=coso_inv*dsinomega(j,1,i)
17482                dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
17483                +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
17484                -sino*dc_norm(j,i)/vbld(i+1)
17485                domega(j,2,i)=coso_inv*dsinomega(j,2,i)
17486                dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
17487                fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
17488                vbld(i+nres)
17489                domega(j,3,i)=coso_inv*dsinomega(j,3,i)
17490               enddo
17491              else
17492       !   obtaining the derivatives of omega from cosines
17493              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
17494              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
17495              fac12=fac10*sina
17496              fac13=fac12*fac12
17497              fac14=sina*sina
17498              do j=1,3
17499               dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
17500               dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
17501               (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
17502               fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
17503               domega(j,1,i)=-1/sino*dcosomega(j,1,i)
17504               dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
17505               dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
17506               dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
17507               (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
17508               dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
17509               domega(j,2,i)=-1/sino*dcosomega(j,2,i)
17510               dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
17511               scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
17512               (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
17513               domega(j,3,i)=-1/sino*dcosomega(j,3,i)
17514             enddo
17515             endif
17516            else
17517              do j=1,3
17518              do k=1,3
17519                dalpha(k,j,i)=0.0d0
17520                domega(k,j,i)=0.0d0
17521              enddo
17522              enddo
17523            endif
17524            enddo
17525 #endif
17526 #if defined(MPI) && defined(PARINTDER)
17527           if (nfgtasks.gt.1) then
17528 #ifdef DEBUG
17529       !d      write (iout,*) "Gather dtheta"
17530       !d      call flush(iout)
17531           write (iout,*) "dtheta before gather"
17532           do i=1,nres
17533           write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
17534           enddo
17535 #endif
17536           call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
17537           MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
17538           king,FG_COMM,IERROR)
17539 !#define DEBUG
17540 #ifdef DEBUG
17541       !d      write (iout,*) "Gather dphi"
17542       !d      call flush(iout)
17543           write (iout,*) "dphi before gather"
17544           do i=1,nres
17545           write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
17546           enddo
17547 #endif
17548 !#undef DEBUG
17549           call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
17550           MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
17551           king,FG_COMM,IERROR)
17552       !d      write (iout,*) "Gather dalpha"
17553       !d      call flush(iout)
17554 #ifdef CRYST_SC
17555           call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
17556           MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17557           king,FG_COMM,IERROR)
17558       !d      write (iout,*) "Gather domega"
17559       !d      call flush(iout)
17560           call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
17561           MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17562           king,FG_COMM,IERROR)
17563 #endif
17564           endif
17565 #endif
17566 !#define DEBUG
17567 #ifdef DEBUG
17568           write (iout,*) "dtheta after gather"
17569           do i=1,nres
17570           write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
17571           enddo
17572           write (iout,*) "dphi after gather"
17573           do i=1,nres
17574           write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
17575           enddo
17576           write (iout,*) "dalpha after gather"
17577           do i=1,nres
17578           write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
17579           enddo
17580           write (iout,*) "domega after gather"
17581           do i=1,nres
17582           write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
17583           enddo
17584 #endif
17585 !#undef DEBUG
17586           return
17587           end subroutine intcartderiv
17588       !-----------------------------------------------------------------------------
17589           subroutine checkintcartgrad
17590       !      implicit real*8 (a-h,o-z)
17591       !      include 'DIMENSIONS'
17592 #ifdef MPI
17593           include 'mpif.h'
17594 #endif
17595       !      include 'COMMON.CHAIN'
17596       !      include 'COMMON.VAR'
17597       !      include 'COMMON.GEO'
17598       !      include 'COMMON.INTERACT'
17599       !      include 'COMMON.DERIV'
17600       !      include 'COMMON.IOUNITS'
17601       !      include 'COMMON.SETUP'
17602           real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
17603           real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
17604           real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
17605           real(kind=8),dimension(3) :: dc_norm_s
17606           real(kind=8) :: aincr=1.0d-5
17607           integer :: i,j
17608           real(kind=8) :: dcji
17609           do i=1,nres
17610           phi_s(i)=phi(i)
17611           theta_s(i)=theta(i)
17612           alph_s(i)=alph(i)
17613           omeg_s(i)=omeg(i)
17614           enddo
17615       ! Check theta gradient
17616           write (iout,*) &
17617            "Analytical (upper) and numerical (lower) gradient of theta"
17618           write (iout,*)
17619           do i=3,nres
17620           do j=1,3
17621             dcji=dc(j,i-2)
17622             dc(j,i-2)=dcji+aincr
17623             call chainbuild_cart
17624             call int_from_cart1(.false.)
17625         dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
17626         dc(j,i-2)=dcji
17627         dcji=dc(j,i-1)
17628         dc(j,i-1)=dc(j,i-1)+aincr
17629         call chainbuild_cart
17630         dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
17631         dc(j,i-1)=dcji
17632       enddo
17633 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
17634 !el          (dtheta(j,2,i),j=1,3)
17635 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
17636 !el          (dthetanum(j,2,i),j=1,3)
17637 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
17638 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
17639 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
17640 !el        write (iout,*)
17641       enddo
17642 ! Check gamma gradient
17643       write (iout,*) &
17644        "Analytical (upper) and numerical (lower) gradient of gamma"
17645       do i=4,nres
17646       do j=1,3
17647         dcji=dc(j,i-3)
17648         dc(j,i-3)=dcji+aincr
17649         call chainbuild_cart
17650         dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
17651             dc(j,i-3)=dcji
17652         dcji=dc(j,i-2)
17653         dc(j,i-2)=dcji+aincr
17654         call chainbuild_cart
17655         dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
17656         dc(j,i-2)=dcji
17657         dcji=dc(j,i-1)
17658         dc(j,i-1)=dc(j,i-1)+aincr
17659         call chainbuild_cart
17660         dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
17661         dc(j,i-1)=dcji
17662       enddo
17663 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
17664 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
17665 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
17666 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
17667 !el        write (iout,'(5x,3(3f10.5,5x))') &
17668 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
17669 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
17670 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
17671 !el        write (iout,*)
17672       enddo
17673 ! Check alpha gradient
17674       write (iout,*) &
17675        "Analytical (upper) and numerical (lower) gradient of alpha"
17676       do i=2,nres-1
17677        if(itype(i,1).ne.10) then
17678              do j=1,3
17679               dcji=dc(j,i-1)
17680                dc(j,i-1)=dcji+aincr
17681             call chainbuild_cart
17682             dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
17683              /aincr
17684               dc(j,i-1)=dcji
17685             dcji=dc(j,i)
17686             dc(j,i)=dcji+aincr
17687             call chainbuild_cart
17688             dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
17689              /aincr
17690             dc(j,i)=dcji
17691             dcji=dc(j,i+nres)
17692             dc(j,i+nres)=dc(j,i+nres)+aincr
17693             call chainbuild_cart
17694             dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
17695              /aincr
17696            dc(j,i+nres)=dcji
17697           enddo
17698         endif
17699 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
17700 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
17701 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
17702 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
17703 !el        write (iout,'(5x,3(3f10.5,5x))') &
17704 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
17705 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
17706 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
17707 !el        write (iout,*)
17708       enddo
17709 !     Check omega gradient
17710       write (iout,*) &
17711        "Analytical (upper) and numerical (lower) gradient of omega"
17712       do i=2,nres-1
17713        if(itype(i,1).ne.10) then
17714              do j=1,3
17715               dcji=dc(j,i-1)
17716                dc(j,i-1)=dcji+aincr
17717             call chainbuild_cart
17718             domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
17719              /aincr
17720               dc(j,i-1)=dcji
17721             dcji=dc(j,i)
17722             dc(j,i)=dcji+aincr
17723             call chainbuild_cart
17724             domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
17725              /aincr
17726             dc(j,i)=dcji
17727             dcji=dc(j,i+nres)
17728             dc(j,i+nres)=dc(j,i+nres)+aincr
17729             call chainbuild_cart
17730             domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
17731              /aincr
17732            dc(j,i+nres)=dcji
17733           enddo
17734         endif
17735 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
17736 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
17737 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
17738 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
17739 !el        write (iout,'(5x,3(3f10.5,5x))') &
17740 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
17741 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
17742 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
17743 !el        write (iout,*)
17744       enddo
17745       return
17746       end subroutine checkintcartgrad
17747 !-----------------------------------------------------------------------------
17748 ! q_measure.F
17749 !-----------------------------------------------------------------------------
17750       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
17751 !      implicit real*8 (a-h,o-z)
17752 !      include 'DIMENSIONS'
17753 !      include 'COMMON.IOUNITS'
17754 !      include 'COMMON.CHAIN'
17755 !      include 'COMMON.INTERACT'
17756 !      include 'COMMON.VAR'
17757       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
17758       integer :: kkk,nsep=3
17759       real(kind=8) :: qm      !dist,
17760       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
17761       logical :: lprn=.false.
17762       logical :: flag
17763 !      real(kind=8) :: sigm,x
17764
17765 !el      sigm(x)=0.25d0*x     ! local function
17766       qqmax=1.0d10
17767       do kkk=1,nperm
17768       qq = 0.0d0
17769       nl=0
17770        if(flag) then
17771       do il=seg1+nsep,seg2
17772         do jl=seg1,il-nsep
17773           nl=nl+1
17774           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
17775                    (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
17776                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17777           dij=dist(il,jl)
17778           qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17779           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17780             nl=nl+1
17781             d0ijCM=dsqrt( &
17782                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17783                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17784                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17785             dijCM=dist(il+nres,jl+nres)
17786             qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17787           endif
17788           qq = qq+qqij+qqijCM
17789         enddo
17790       enddo
17791       qq = qq/nl
17792       else
17793       do il=seg1,seg2
17794       if((seg3-il).lt.3) then
17795            secseg=il+3
17796       else
17797            secseg=seg3
17798       endif
17799         do jl=secseg,seg4
17800           nl=nl+1
17801           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17802                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17803                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17804           dij=dist(il,jl)
17805           qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17806           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17807             nl=nl+1
17808             d0ijCM=dsqrt( &
17809                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17810                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17811                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17812             dijCM=dist(il+nres,jl+nres)
17813             qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17814           endif
17815           qq = qq+qqij+qqijCM
17816         enddo
17817       enddo
17818       qq = qq/nl
17819       endif
17820       if (qqmax.le.qq) qqmax=qq
17821       enddo
17822       qwolynes=1.0d0-qqmax
17823       return
17824       end function qwolynes
17825 !-----------------------------------------------------------------------------
17826       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
17827 !      implicit real*8 (a-h,o-z)
17828 !      include 'DIMENSIONS'
17829 !      include 'COMMON.IOUNITS'
17830 !      include 'COMMON.CHAIN'
17831 !      include 'COMMON.INTERACT'
17832 !      include 'COMMON.VAR'
17833 !      include 'COMMON.MD'
17834       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
17835       integer :: nsep=3, kkk
17836 !el      real(kind=8) :: dist
17837       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
17838       logical :: lprn=.false.
17839       logical :: flag
17840       real(kind=8) :: sim,dd0,fac,ddqij
17841 !el      sigm(x)=0.25d0*x           ! local function
17842       do kkk=1,nperm
17843       do i=0,nres
17844       do j=1,3
17845         dqwol(j,i)=0.0d0
17846         dxqwol(j,i)=0.0d0
17847       enddo
17848       enddo
17849       nl=0
17850        if(flag) then
17851       do il=seg1+nsep,seg2
17852         do jl=seg1,il-nsep
17853           nl=nl+1
17854           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17855                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17856                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17857           dij=dist(il,jl)
17858           sim = 1.0d0/sigm(d0ij)
17859           sim = sim*sim
17860           dd0 = dij-d0ij
17861           fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17862         do k=1,3
17863             ddqij = (c(k,il)-c(k,jl))*fac
17864             dqwol(k,il)=dqwol(k,il)+ddqij
17865             dqwol(k,jl)=dqwol(k,jl)-ddqij
17866           enddo
17867
17868           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17869             nl=nl+1
17870             d0ijCM=dsqrt( &
17871                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17872                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17873                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17874             dijCM=dist(il+nres,jl+nres)
17875             sim = 1.0d0/sigm(d0ijCM)
17876             sim = sim*sim
17877             dd0=dijCM-d0ijCM
17878             fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17879             do k=1,3
17880             ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17881             dxqwol(k,il)=dxqwol(k,il)+ddqij
17882             dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17883             enddo
17884           endif
17885         enddo
17886       enddo
17887        else
17888       do il=seg1,seg2
17889       if((seg3-il).lt.3) then
17890            secseg=il+3
17891       else
17892            secseg=seg3
17893       endif
17894         do jl=secseg,seg4
17895           nl=nl+1
17896           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17897                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17898                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17899           dij=dist(il,jl)
17900           sim = 1.0d0/sigm(d0ij)
17901           sim = sim*sim
17902           dd0 = dij-d0ij
17903           fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17904           do k=1,3
17905             ddqij = (c(k,il)-c(k,jl))*fac
17906             dqwol(k,il)=dqwol(k,il)+ddqij
17907             dqwol(k,jl)=dqwol(k,jl)-ddqij
17908           enddo
17909           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17910             nl=nl+1
17911             d0ijCM=dsqrt( &
17912                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17913                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17914                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17915             dijCM=dist(il+nres,jl+nres)
17916             sim = 1.0d0/sigm(d0ijCM)
17917             sim=sim*sim
17918             dd0 = dijCM-d0ijCM
17919             fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17920             do k=1,3
17921              ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17922              dxqwol(k,il)=dxqwol(k,il)+ddqij
17923              dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17924             enddo
17925           endif
17926         enddo
17927       enddo
17928       endif
17929       enddo
17930        do i=0,nres
17931        do j=1,3
17932          dqwol(j,i)=dqwol(j,i)/nl
17933          dxqwol(j,i)=dxqwol(j,i)/nl
17934        enddo
17935        enddo
17936       return
17937       end subroutine qwolynes_prim
17938 !-----------------------------------------------------------------------------
17939       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
17940 !      implicit real*8 (a-h,o-z)
17941 !      include 'DIMENSIONS'
17942 !      include 'COMMON.IOUNITS'
17943 !      include 'COMMON.CHAIN'
17944 !      include 'COMMON.INTERACT'
17945 !      include 'COMMON.VAR'
17946       integer :: seg1,seg2,seg3,seg4
17947       logical :: flag
17948       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
17949       real(kind=8),dimension(3,0:2*nres) :: cdummy
17950       real(kind=8) :: q1,q2
17951       real(kind=8) :: delta=1.0d-10
17952       integer :: i,j
17953
17954       do i=0,nres
17955       do j=1,3
17956         q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17957         cdummy(j,i)=c(j,i)
17958         c(j,i)=c(j,i)+delta
17959         q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17960         qwolan(j,i)=(q2-q1)/delta
17961         c(j,i)=cdummy(j,i)
17962       enddo
17963       enddo
17964       do i=0,nres
17965       do j=1,3
17966         q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17967         cdummy(j,i+nres)=c(j,i+nres)
17968         c(j,i+nres)=c(j,i+nres)+delta
17969         q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17970         qwolxan(j,i)=(q2-q1)/delta
17971         c(j,i+nres)=cdummy(j,i+nres)
17972       enddo
17973       enddo
17974 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
17975 !      do i=0,nct
17976 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
17977 !      enddo
17978 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
17979 !      do i=0,nct
17980 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
17981 !      enddo
17982       return
17983       end subroutine qwol_num
17984 !-----------------------------------------------------------------------------
17985       subroutine EconstrQ
17986 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
17987 !      implicit real*8 (a-h,o-z)
17988 !      include 'DIMENSIONS'
17989 !      include 'COMMON.CONTROL'
17990 !      include 'COMMON.VAR'
17991 !      include 'COMMON.MD'
17992       use MD_data
17993 !#ifndef LANG0
17994 !      include 'COMMON.LANGEVIN'
17995 !#else
17996 !      include 'COMMON.LANGEVIN.lang0'
17997 !#endif
17998 !      include 'COMMON.CHAIN'
17999 !      include 'COMMON.DERIV'
18000 !      include 'COMMON.GEO'
18001 !      include 'COMMON.LOCAL'
18002 !      include 'COMMON.INTERACT'
18003 !      include 'COMMON.IOUNITS'
18004 !      include 'COMMON.NAMES'
18005 !      include 'COMMON.TIME1'
18006       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
18007       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
18008                duconst,duxconst
18009       integer :: kstart,kend,lstart,lend,idummy
18010       real(kind=8) :: delta=1.0d-7
18011       integer :: i,j,k,ii
18012       do i=0,nres
18013        do j=1,3
18014           duconst(j,i)=0.0d0
18015           dudconst(j,i)=0.0d0
18016           duxconst(j,i)=0.0d0
18017           dudxconst(j,i)=0.0d0
18018        enddo
18019       enddo
18020       Uconst=0.0d0
18021       do i=1,nfrag
18022        qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18023          idummy,idummy)
18024        Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
18025 ! Calculating the derivatives of Constraint energy with respect to Q
18026        Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
18027          qinfrag(i,iset))
18028 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
18029 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
18030 !         hmnum=(hm2-hm1)/delta
18031 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
18032 !     &   qinfrag(i,iset))
18033 !         write(iout,*) "harmonicnum frag", hmnum
18034 ! Calculating the derivatives of Q with respect to cartesian coordinates
18035        call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18036         idummy,idummy)
18037 !         write(iout,*) "dqwol "
18038 !         do ii=1,nres
18039 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18040 !         enddo
18041 !         write(iout,*) "dxqwol "
18042 !         do ii=1,nres
18043 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18044 !         enddo
18045 ! Calculating numerical gradients of dU/dQi and dQi/dxi
18046 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
18047 !     &  ,idummy,idummy)
18048 !  The gradients of Uconst in Cs
18049        do ii=0,nres
18050           do j=1,3
18051              duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
18052              dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
18053           enddo
18054        enddo
18055       enddo
18056       do i=1,npair
18057        kstart=ifrag(1,ipair(1,i,iset),iset)
18058        kend=ifrag(2,ipair(1,i,iset),iset)
18059        lstart=ifrag(1,ipair(2,i,iset),iset)
18060        lend=ifrag(2,ipair(2,i,iset),iset)
18061        qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
18062        Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
18063 !  Calculating dU/dQ
18064        Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
18065 !         hm1=harmonic(qpair(i),qinpair(i,iset))
18066 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
18067 !         hmnum=(hm2-hm1)/delta
18068 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
18069 !     &   qinpair(i,iset))
18070 !         write(iout,*) "harmonicnum pair ", hmnum
18071 ! Calculating dQ/dXi
18072        call qwolynes_prim(kstart,kend,.false.,&
18073         lstart,lend)
18074 !         write(iout,*) "dqwol "
18075 !         do ii=1,nres
18076 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18077 !         enddo
18078 !         write(iout,*) "dxqwol "
18079 !         do ii=1,nres
18080 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18081 !        enddo
18082 ! Calculating numerical gradients
18083 !        call qwol_num(kstart,kend,.false.
18084 !     &  ,lstart,lend)
18085 ! The gradients of Uconst in Cs
18086        do ii=0,nres
18087           do j=1,3
18088              duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
18089              dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
18090           enddo
18091        enddo
18092       enddo
18093 !      write(iout,*) "Uconst inside subroutine ", Uconst
18094 ! Transforming the gradients from Cs to dCs for the backbone
18095       do i=0,nres
18096        do j=i+1,nres
18097          do k=1,3
18098            dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
18099          enddo
18100        enddo
18101       enddo
18102 !  Transforming the gradients from Cs to dCs for the side chains
18103       do i=1,nres
18104        do j=1,3
18105          dudxconst(j,i)=duxconst(j,i)
18106        enddo
18107       enddo
18108 !      write(iout,*) "dU/ddc backbone "
18109 !       do ii=0,nres
18110 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
18111 !      enddo
18112 !      write(iout,*) "dU/ddX side chain "
18113 !      do ii=1,nres
18114 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
18115 !      enddo
18116 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
18117 !      call dEconstrQ_num
18118       return
18119       end subroutine EconstrQ
18120 !-----------------------------------------------------------------------------
18121       subroutine dEconstrQ_num
18122 ! Calculating numerical dUconst/ddc and dUconst/ddx
18123 !      implicit real*8 (a-h,o-z)
18124 !      include 'DIMENSIONS'
18125 !      include 'COMMON.CONTROL'
18126 !      include 'COMMON.VAR'
18127 !      include 'COMMON.MD'
18128       use MD_data
18129 !#ifndef LANG0
18130 !      include 'COMMON.LANGEVIN'
18131 !#else
18132 !      include 'COMMON.LANGEVIN.lang0'
18133 !#endif
18134 !      include 'COMMON.CHAIN'
18135 !      include 'COMMON.DERIV'
18136 !      include 'COMMON.GEO'
18137 !      include 'COMMON.LOCAL'
18138 !      include 'COMMON.INTERACT'
18139 !      include 'COMMON.IOUNITS'
18140 !      include 'COMMON.NAMES'
18141 !      include 'COMMON.TIME1'
18142       real(kind=8) :: uzap1,uzap2
18143       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
18144       integer :: kstart,kend,lstart,lend,idummy
18145       real(kind=8) :: delta=1.0d-7
18146 !el local variables
18147       integer :: i,ii,j
18148 !     real(kind=8) ::
18149 !     For the backbone
18150       do i=0,nres-1
18151        do j=1,3
18152           dUcartan(j,i)=0.0d0
18153           cdummy(j,i)=dc(j,i)
18154           dc(j,i)=dc(j,i)+delta
18155           call chainbuild_cart
18156         uzap2=0.0d0
18157           do ii=1,nfrag
18158            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18159             idummy,idummy)
18160              uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18161             qinfrag(ii,iset))
18162           enddo
18163           do ii=1,npair
18164              kstart=ifrag(1,ipair(1,ii,iset),iset)
18165              kend=ifrag(2,ipair(1,ii,iset),iset)
18166              lstart=ifrag(1,ipair(2,ii,iset),iset)
18167              lend=ifrag(2,ipair(2,ii,iset),iset)
18168              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18169              uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18170              qinpair(ii,iset))
18171           enddo
18172           dc(j,i)=cdummy(j,i)
18173           call chainbuild_cart
18174           uzap1=0.0d0
18175            do ii=1,nfrag
18176            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18177             idummy,idummy)
18178              uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18179             qinfrag(ii,iset))
18180           enddo
18181           do ii=1,npair
18182              kstart=ifrag(1,ipair(1,ii,iset),iset)
18183              kend=ifrag(2,ipair(1,ii,iset),iset)
18184              lstart=ifrag(1,ipair(2,ii,iset),iset)
18185              lend=ifrag(2,ipair(2,ii,iset),iset)
18186              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18187              uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18188             qinpair(ii,iset))
18189           enddo
18190           ducartan(j,i)=(uzap2-uzap1)/(delta)
18191        enddo
18192       enddo
18193 ! Calculating numerical gradients for dU/ddx
18194       do i=0,nres-1
18195        duxcartan(j,i)=0.0d0
18196        do j=1,3
18197           cdummy(j,i)=dc(j,i+nres)
18198           dc(j,i+nres)=dc(j,i+nres)+delta
18199           call chainbuild_cart
18200         uzap2=0.0d0
18201           do ii=1,nfrag
18202            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18203             idummy,idummy)
18204              uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18205             qinfrag(ii,iset))
18206           enddo
18207           do ii=1,npair
18208              kstart=ifrag(1,ipair(1,ii,iset),iset)
18209              kend=ifrag(2,ipair(1,ii,iset),iset)
18210              lstart=ifrag(1,ipair(2,ii,iset),iset)
18211              lend=ifrag(2,ipair(2,ii,iset),iset)
18212              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18213              uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18214             qinpair(ii,iset))
18215           enddo
18216           dc(j,i+nres)=cdummy(j,i)
18217           call chainbuild_cart
18218           uzap1=0.0d0
18219            do ii=1,nfrag
18220              qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
18221             ifrag(2,ii,iset),.true.,idummy,idummy)
18222              uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18223             qinfrag(ii,iset))
18224           enddo
18225           do ii=1,npair
18226              kstart=ifrag(1,ipair(1,ii,iset),iset)
18227              kend=ifrag(2,ipair(1,ii,iset),iset)
18228              lstart=ifrag(1,ipair(2,ii,iset),iset)
18229              lend=ifrag(2,ipair(2,ii,iset),iset)
18230              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18231              uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18232             qinpair(ii,iset))
18233           enddo
18234           duxcartan(j,i)=(uzap2-uzap1)/(delta)
18235        enddo
18236       enddo
18237       write(iout,*) "Numerical dUconst/ddc backbone "
18238       do ii=0,nres
18239       write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
18240       enddo
18241 !      write(iout,*) "Numerical dUconst/ddx side-chain "
18242 !      do ii=1,nres
18243 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
18244 !      enddo
18245       return
18246       end subroutine dEconstrQ_num
18247 !-----------------------------------------------------------------------------
18248 ! ssMD.F
18249 !-----------------------------------------------------------------------------
18250       subroutine check_energies
18251
18252 !      use random, only: ran_number
18253
18254 !      implicit none
18255 !     Includes
18256 !      include 'DIMENSIONS'
18257 !      include 'COMMON.CHAIN'
18258 !      include 'COMMON.VAR'
18259 !      include 'COMMON.IOUNITS'
18260 !      include 'COMMON.SBRIDGE'
18261 !      include 'COMMON.LOCAL'
18262 !      include 'COMMON.GEO'
18263
18264 !     External functions
18265 !EL      double precision ran_number
18266 !EL      external ran_number
18267
18268 !     Local variables
18269       integer :: i,j,k,l,lmax,p,pmax
18270       real(kind=8) :: rmin,rmax
18271       real(kind=8) :: eij
18272
18273       real(kind=8) :: d
18274       real(kind=8) :: wi,rij,tj,pj
18275 !      return
18276
18277       i=5
18278       j=14
18279
18280       d=dsc(1)
18281       rmin=2.0D0
18282       rmax=12.0D0
18283
18284       lmax=10000
18285       pmax=1
18286
18287       do k=1,3
18288       c(k,i)=0.0D0
18289       c(k,j)=0.0D0
18290       c(k,nres+i)=0.0D0
18291       c(k,nres+j)=0.0D0
18292       enddo
18293
18294       do l=1,lmax
18295
18296 !t        wi=ran_number(0.0D0,pi)
18297 !        wi=ran_number(0.0D0,pi/6.0D0)
18298 !        wi=0.0D0
18299 !t        tj=ran_number(0.0D0,pi)
18300 !t        pj=ran_number(0.0D0,pi)
18301 !        pj=ran_number(0.0D0,pi/6.0D0)
18302 !        pj=0.0D0
18303
18304       do p=1,pmax
18305 !t           rij=ran_number(rmin,rmax)
18306
18307          c(1,j)=d*sin(pj)*cos(tj)
18308          c(2,j)=d*sin(pj)*sin(tj)
18309          c(3,j)=d*cos(pj)
18310
18311          c(3,nres+i)=-rij
18312
18313          c(1,i)=d*sin(wi)
18314          c(3,i)=-rij-d*cos(wi)
18315
18316          do k=1,3
18317             dc(k,nres+i)=c(k,nres+i)-c(k,i)
18318             dc_norm(k,nres+i)=dc(k,nres+i)/d
18319             dc(k,nres+j)=c(k,nres+j)-c(k,j)
18320             dc_norm(k,nres+j)=dc(k,nres+j)/d
18321          enddo
18322
18323          call dyn_ssbond_ene(i,j,eij)
18324       enddo
18325       enddo
18326       call exit(1)
18327       return
18328       end subroutine check_energies
18329 !-----------------------------------------------------------------------------
18330       subroutine dyn_ssbond_ene(resi,resj,eij)
18331 !      implicit none
18332 !      Includes
18333       use calc_data
18334       use comm_sschecks
18335 !      include 'DIMENSIONS'
18336 !      include 'COMMON.SBRIDGE'
18337 !      include 'COMMON.CHAIN'
18338 !      include 'COMMON.DERIV'
18339 !      include 'COMMON.LOCAL'
18340 !      include 'COMMON.INTERACT'
18341 !      include 'COMMON.VAR'
18342 !      include 'COMMON.IOUNITS'
18343 !      include 'COMMON.CALC'
18344 #ifndef CLUST
18345 #ifndef WHAM
18346        use MD_data
18347 !      include 'COMMON.MD'
18348 !      use MD, only: totT,t_bath
18349 #endif
18350 #endif
18351 !     External functions
18352 !EL      double precision h_base
18353 !EL      external h_base
18354
18355 !     Input arguments
18356       integer :: resi,resj
18357
18358 !     Output arguments
18359       real(kind=8) :: eij
18360
18361 !     Local variables
18362       logical :: havebond
18363       integer itypi,itypj
18364       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
18365       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
18366       real(kind=8),dimension(3) :: dcosom1,dcosom2
18367       real(kind=8) :: ed
18368       real(kind=8) :: pom1,pom2
18369       real(kind=8) :: ljA,ljB,ljXs
18370       real(kind=8),dimension(1:3) :: d_ljB
18371       real(kind=8) :: ssA,ssB,ssC,ssXs
18372       real(kind=8) :: ssxm,ljxm,ssm,ljm
18373       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
18374       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
18375       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
18376 !-------FIRST METHOD
18377       real(kind=8) :: xm
18378       real(kind=8),dimension(1:3) :: d_xm
18379 !-------END FIRST METHOD
18380 !-------SECOND METHOD
18381 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
18382 !-------END SECOND METHOD
18383
18384 !-------TESTING CODE
18385 !el      logical :: checkstop,transgrad
18386 !el      common /sschecks/ checkstop,transgrad
18387
18388       integer :: icheck,nicheck,jcheck,njcheck
18389       real(kind=8),dimension(-1:1) :: echeck
18390       real(kind=8) :: deps,ssx0,ljx0
18391 !-------END TESTING CODE
18392
18393       eij=0.0d0
18394       i=resi
18395       j=resj
18396
18397 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
18398 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
18399
18400       itypi=itype(i,1)
18401       dxi=dc_norm(1,nres+i)
18402       dyi=dc_norm(2,nres+i)
18403       dzi=dc_norm(3,nres+i)
18404       dsci_inv=vbld_inv(i+nres)
18405
18406       itypj=itype(j,1)
18407       xj=c(1,nres+j)-c(1,nres+i)
18408       yj=c(2,nres+j)-c(2,nres+i)
18409       zj=c(3,nres+j)-c(3,nres+i)
18410       dxj=dc_norm(1,nres+j)
18411       dyj=dc_norm(2,nres+j)
18412       dzj=dc_norm(3,nres+j)
18413       dscj_inv=vbld_inv(j+nres)
18414
18415       chi1=chi(itypi,itypj)
18416       chi2=chi(itypj,itypi)
18417       chi12=chi1*chi2
18418       chip1=chip(itypi)
18419       chip2=chip(itypj)
18420       chip12=chip1*chip2
18421       alf1=alp(itypi)
18422       alf2=alp(itypj)
18423       alf12=0.5D0*(alf1+alf2)
18424
18425       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
18426       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18427 !     The following are set in sc_angular
18428 !      erij(1)=xj*rij
18429 !      erij(2)=yj*rij
18430 !      erij(3)=zj*rij
18431 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
18432 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
18433 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
18434       call sc_angular
18435       rij=1.0D0/rij  ! Reset this so it makes sense
18436
18437       sig0ij=sigma(itypi,itypj)
18438       sig=sig0ij*dsqrt(1.0D0/sigsq)
18439
18440       ljXs=sig-sig0ij
18441       ljA=eps1*eps2rt**2*eps3rt**2
18442       ljB=ljA*bb_aq(itypi,itypj)
18443       ljA=ljA*aa_aq(itypi,itypj)
18444       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
18445
18446       ssXs=d0cm
18447       deltat1=1.0d0-om1
18448       deltat2=1.0d0+om2
18449       deltat12=om2-om1+2.0d0
18450       cosphi=om12-om1*om2
18451       ssA=akcm
18452       ssB=akct*deltat12
18453       ssC=ss_depth &
18454          +akth*(deltat1*deltat1+deltat2*deltat2) &
18455          +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
18456       ssxm=ssXs-0.5D0*ssB/ssA
18457
18458 !-------TESTING CODE
18459 !$$$c     Some extra output
18460 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
18461 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
18462 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
18463 !$$$      if (ssx0.gt.0.0d0) then
18464 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
18465 !$$$      else
18466 !$$$        ssx0=ssxm
18467 !$$$      endif
18468 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
18469 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
18470 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
18471 !$$$      return
18472 !-------END TESTING CODE
18473
18474 !-------TESTING CODE
18475 !     Stop and plot energy and derivative as a function of distance
18476       if (checkstop) then
18477       ssm=ssC-0.25D0*ssB*ssB/ssA
18478       ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18479       if (ssm.lt.ljm .and. &
18480            dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
18481         nicheck=1000
18482         njcheck=1
18483         deps=0.5d-7
18484       else
18485         checkstop=.false.
18486       endif
18487       endif
18488       if (.not.checkstop) then
18489       nicheck=0
18490       njcheck=-1
18491       endif
18492
18493       do icheck=0,nicheck
18494       do jcheck=-1,njcheck
18495       if (checkstop) rij=(ssxm-1.0d0)+ &
18496            ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
18497 !-------END TESTING CODE
18498
18499       if (rij.gt.ljxm) then
18500       havebond=.false.
18501       ljd=rij-ljXs
18502       fac=(1.0D0/ljd)**expon
18503       e1=fac*fac*aa_aq(itypi,itypj)
18504       e2=fac*bb_aq(itypi,itypj)
18505       eij=eps1*eps2rt*eps3rt*(e1+e2)
18506       eps2der=eij*eps3rt
18507       eps3der=eij*eps2rt
18508       eij=eij*eps2rt*eps3rt
18509
18510       sigder=-sig/sigsq
18511       e1=e1*eps1*eps2rt**2*eps3rt**2
18512       ed=-expon*(e1+eij)/ljd
18513       sigder=ed*sigder
18514       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
18515       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
18516       eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
18517            -2.0D0*alf12*eps3der+sigder*sigsq_om12
18518       else if (rij.lt.ssxm) then
18519       havebond=.true.
18520       ssd=rij-ssXs
18521       eij=ssA*ssd*ssd+ssB*ssd+ssC
18522
18523       ed=2*akcm*ssd+akct*deltat12
18524       pom1=akct*ssd
18525       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
18526       eom1=-2*akth*deltat1-pom1-om2*pom2
18527       eom2= 2*akth*deltat2+pom1-om1*pom2
18528       eom12=pom2
18529       else
18530       omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
18531
18532       d_ssxm(1)=0.5D0*akct/ssA
18533       d_ssxm(2)=-d_ssxm(1)
18534       d_ssxm(3)=0.0D0
18535
18536       d_ljxm(1)=sig0ij/sqrt(sigsq**3)
18537       d_ljxm(2)=d_ljxm(1)*sigsq_om2
18538       d_ljxm(3)=d_ljxm(1)*sigsq_om12
18539       d_ljxm(1)=d_ljxm(1)*sigsq_om1
18540
18541 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18542       xm=0.5d0*(ssxm+ljxm)
18543       do k=1,3
18544         d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
18545       enddo
18546       if (rij.lt.xm) then
18547         havebond=.true.
18548         ssm=ssC-0.25D0*ssB*ssB/ssA
18549         d_ssm(1)=0.5D0*akct*ssB/ssA
18550         d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18551         d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18552         d_ssm(3)=omega
18553         f1=(rij-xm)/(ssxm-xm)
18554         f2=(rij-ssxm)/(xm-ssxm)
18555         h1=h_base(f1,hd1)
18556         h2=h_base(f2,hd2)
18557         eij=ssm*h1+Ht*h2
18558         delta_inv=1.0d0/(xm-ssxm)
18559         deltasq_inv=delta_inv*delta_inv
18560         fac=ssm*hd1-Ht*hd2
18561         fac1=deltasq_inv*fac*(xm-rij)
18562         fac2=deltasq_inv*fac*(rij-ssxm)
18563         ed=delta_inv*(Ht*hd2-ssm*hd1)
18564         eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
18565         eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
18566         eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
18567       else
18568         havebond=.false.
18569         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18570         d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
18571         d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
18572         d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
18573              alf12/eps3rt)
18574         d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
18575         f1=(rij-ljxm)/(xm-ljxm)
18576         f2=(rij-xm)/(ljxm-xm)
18577         h1=h_base(f1,hd1)
18578         h2=h_base(f2,hd2)
18579         eij=Ht*h1+ljm*h2
18580         delta_inv=1.0d0/(ljxm-xm)
18581         deltasq_inv=delta_inv*delta_inv
18582         fac=Ht*hd1-ljm*hd2
18583         fac1=deltasq_inv*fac*(ljxm-rij)
18584         fac2=deltasq_inv*fac*(rij-xm)
18585         ed=delta_inv*(ljm*hd2-Ht*hd1)
18586         eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
18587         eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
18588         eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
18589       endif
18590 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18591
18592 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18593 !$$$        ssd=rij-ssXs
18594 !$$$        ljd=rij-ljXs
18595 !$$$        fac1=rij-ljxm
18596 !$$$        fac2=rij-ssxm
18597 !$$$
18598 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
18599 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
18600 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
18601 !$$$
18602 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
18603 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
18604 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18605 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18606 !$$$        d_ssm(3)=omega
18607 !$$$
18608 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
18609 !$$$        do k=1,3
18610 !$$$          d_ljm(k)=ljm*d_ljB(k)
18611 !$$$        enddo
18612 !$$$        ljm=ljm*ljB
18613 !$$$
18614 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
18615 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
18616 !$$$        d_ss(2)=akct*ssd
18617 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
18618 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
18619 !$$$        d_ss(3)=omega
18620 !$$$
18621 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
18622 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
18623 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
18624 !$$$        do k=1,3
18625 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
18626 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
18627 !$$$        enddo
18628 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
18629 !$$$
18630 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
18631 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
18632 !$$$        h1=h_base(f1,hd1)
18633 !$$$        h2=h_base(f2,hd2)
18634 !$$$        eij=ss*h1+ljf*h2
18635 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
18636 !$$$        deltasq_inv=delta_inv*delta_inv
18637 !$$$        fac=ljf*hd2-ss*hd1
18638 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
18639 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
18640 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
18641 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
18642 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
18643 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
18644 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
18645 !$$$
18646 !$$$        havebond=.false.
18647 !$$$        if (ed.gt.0.0d0) havebond=.true.
18648 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18649
18650       endif
18651
18652       if (havebond) then
18653 !#ifndef CLUST
18654 !#ifndef WHAM
18655 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
18656 !          write(iout,'(a15,f12.2,f8.1,2i5)')
18657 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
18658 !        endif
18659 !#endif
18660 !#endif
18661       dyn_ssbond_ij(i,j)=eij
18662       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
18663       dyn_ssbond_ij(i,j)=1.0d300
18664 !#ifndef CLUST
18665 !#ifndef WHAM
18666 !        write(iout,'(a15,f12.2,f8.1,2i5)')
18667 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
18668 !#endif
18669 !#endif
18670       endif
18671
18672 !-------TESTING CODE
18673 !el      if (checkstop) then
18674       if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
18675            "CHECKSTOP",rij,eij,ed
18676       echeck(jcheck)=eij
18677 !el      endif
18678       enddo
18679       if (checkstop) then
18680       write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
18681       endif
18682       enddo
18683       if (checkstop) then
18684       transgrad=.true.
18685       checkstop=.false.
18686       endif
18687 !-------END TESTING CODE
18688
18689       do k=1,3
18690       dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
18691       dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
18692       enddo
18693       do k=1,3
18694       gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
18695       enddo
18696       do k=1,3
18697       gvdwx(k,i)=gvdwx(k,i)-gg(k) &
18698            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
18699            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
18700       gvdwx(k,j)=gvdwx(k,j)+gg(k) &
18701            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
18702            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
18703       enddo
18704 !grad      do k=i,j-1
18705 !grad        do l=1,3
18706 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
18707 !grad        enddo
18708 !grad      enddo
18709
18710       do l=1,3
18711       gvdwc(l,i)=gvdwc(l,i)-gg(l)
18712       gvdwc(l,j)=gvdwc(l,j)+gg(l)
18713       enddo
18714
18715       return
18716       end subroutine dyn_ssbond_ene
18717 !--------------------------------------------------------------------------
18718        subroutine triple_ssbond_ene(resi,resj,resk,eij)
18719 !      implicit none
18720 !      Includes
18721       use calc_data
18722       use comm_sschecks
18723 !      include 'DIMENSIONS'
18724 !      include 'COMMON.SBRIDGE'
18725 !      include 'COMMON.CHAIN'
18726 !      include 'COMMON.DERIV'
18727 !      include 'COMMON.LOCAL'
18728 !      include 'COMMON.INTERACT'
18729 !      include 'COMMON.VAR'
18730 !      include 'COMMON.IOUNITS'
18731 !      include 'COMMON.CALC'
18732 #ifndef CLUST
18733 #ifndef WHAM
18734        use MD_data
18735 !      include 'COMMON.MD'
18736 !      use MD, only: totT,t_bath
18737 #endif
18738 #endif
18739       double precision h_base
18740       external h_base
18741
18742 !c     Input arguments
18743       integer resi,resj,resk,m,itypi,itypj,itypk
18744
18745 !c     Output arguments
18746       double precision eij,eij1,eij2,eij3
18747
18748 !c     Local variables
18749       logical havebond
18750 !c      integer itypi,itypj,k,l
18751       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
18752       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
18753       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
18754       double precision sig0ij,ljd,sig,fac,e1,e2
18755       double precision dcosom1(3),dcosom2(3),ed
18756       double precision pom1,pom2
18757       double precision ljA,ljB,ljXs
18758       double precision d_ljB(1:3)
18759       double precision ssA,ssB,ssC,ssXs
18760       double precision ssxm,ljxm,ssm,ljm
18761       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
18762       eij=0.0
18763       if (dtriss.eq.0) return
18764       i=resi
18765       j=resj
18766       k=resk
18767 !C      write(iout,*) resi,resj,resk
18768       itypi=itype(i,1)
18769       dxi=dc_norm(1,nres+i)
18770       dyi=dc_norm(2,nres+i)
18771       dzi=dc_norm(3,nres+i)
18772       dsci_inv=vbld_inv(i+nres)
18773       xi=c(1,nres+i)
18774       yi=c(2,nres+i)
18775       zi=c(3,nres+i)
18776       call to_box(xi,yi,zi)
18777       itypj=itype(j,1)
18778       xj=c(1,nres+j)
18779       yj=c(2,nres+j)
18780       zj=c(3,nres+j)
18781       call to_box(xj,yj,zj)
18782       dxj=dc_norm(1,nres+j)
18783       dyj=dc_norm(2,nres+j)
18784       dzj=dc_norm(3,nres+j)
18785       dscj_inv=vbld_inv(j+nres)
18786       itypk=itype(k,1)
18787       xk=c(1,nres+k)
18788       yk=c(2,nres+k)
18789       zk=c(3,nres+k)
18790        call to_box(xk,yk,zk)
18791       dxk=dc_norm(1,nres+k)
18792       dyk=dc_norm(2,nres+k)
18793       dzk=dc_norm(3,nres+k)
18794       dscj_inv=vbld_inv(k+nres)
18795       xij=xj-xi
18796       xik=xk-xi
18797       xjk=xk-xj
18798       yij=yj-yi
18799       yik=yk-yi
18800       yjk=yk-yj
18801       zij=zj-zi
18802       zik=zk-zi
18803       zjk=zk-zj
18804       rrij=(xij*xij+yij*yij+zij*zij)
18805       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18806       rrik=(xik*xik+yik*yik+zik*zik)
18807       rik=dsqrt(rrik)
18808       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
18809       rjk=dsqrt(rrjk)
18810 !C there are three combination of distances for each trisulfide bonds
18811 !C The first case the ith atom is the center
18812 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
18813 !C distance y is second distance the a,b,c,d are parameters derived for
18814 !C this problem d parameter was set as a penalty currenlty set to 1.
18815       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
18816       eij1=0.0d0
18817       else
18818       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
18819       endif
18820 !C second case jth atom is center
18821       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
18822       eij2=0.0d0
18823       else
18824       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
18825       endif
18826 !C the third case kth atom is the center
18827       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
18828       eij3=0.0d0
18829       else
18830       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
18831       endif
18832 !C      eij2=0.0
18833 !C      eij3=0.0
18834 !C      eij1=0.0
18835       eij=eij1+eij2+eij3
18836 !C      write(iout,*)i,j,k,eij
18837 !C The energy penalty calculated now time for the gradient part
18838 !C derivative over rij
18839       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18840       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
18841           gg(1)=xij*fac/rij
18842           gg(2)=yij*fac/rij
18843           gg(3)=zij*fac/rij
18844       do m=1,3
18845       gvdwx(m,i)=gvdwx(m,i)-gg(m)
18846       gvdwx(m,j)=gvdwx(m,j)+gg(m)
18847       enddo
18848
18849       do l=1,3
18850       gvdwc(l,i)=gvdwc(l,i)-gg(l)
18851       gvdwc(l,j)=gvdwc(l,j)+gg(l)
18852       enddo
18853 !C now derivative over rik
18854       fac=-eij1**2/dtriss* &
18855       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18856       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18857           gg(1)=xik*fac/rik
18858           gg(2)=yik*fac/rik
18859           gg(3)=zik*fac/rik
18860       do m=1,3
18861       gvdwx(m,i)=gvdwx(m,i)-gg(m)
18862       gvdwx(m,k)=gvdwx(m,k)+gg(m)
18863       enddo
18864       do l=1,3
18865       gvdwc(l,i)=gvdwc(l,i)-gg(l)
18866       gvdwc(l,k)=gvdwc(l,k)+gg(l)
18867       enddo
18868 !C now derivative over rjk
18869       fac=-eij2**2/dtriss* &
18870       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
18871       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18872           gg(1)=xjk*fac/rjk
18873           gg(2)=yjk*fac/rjk
18874           gg(3)=zjk*fac/rjk
18875       do m=1,3
18876       gvdwx(m,j)=gvdwx(m,j)-gg(m)
18877       gvdwx(m,k)=gvdwx(m,k)+gg(m)
18878       enddo
18879       do l=1,3
18880       gvdwc(l,j)=gvdwc(l,j)-gg(l)
18881       gvdwc(l,k)=gvdwc(l,k)+gg(l)
18882       enddo
18883       return
18884       end subroutine triple_ssbond_ene
18885
18886
18887
18888 !-----------------------------------------------------------------------------
18889       real(kind=8) function h_base(x,deriv)
18890 !     A smooth function going 0->1 in range [0,1]
18891 !     It should NOT be called outside range [0,1], it will not work there.
18892       implicit none
18893
18894 !     Input arguments
18895       real(kind=8) :: x
18896
18897 !     Output arguments
18898       real(kind=8) :: deriv
18899
18900 !     Local variables
18901       real(kind=8) :: xsq
18902
18903
18904 !     Two parabolas put together.  First derivative zero at extrema
18905 !$$$      if (x.lt.0.5D0) then
18906 !$$$        h_base=2.0D0*x*x
18907 !$$$        deriv=4.0D0*x
18908 !$$$      else
18909 !$$$        deriv=1.0D0-x
18910 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
18911 !$$$        deriv=4.0D0*deriv
18912 !$$$      endif
18913
18914 !     Third degree polynomial.  First derivative zero at extrema
18915       h_base=x*x*(3.0d0-2.0d0*x)
18916       deriv=6.0d0*x*(1.0d0-x)
18917
18918 !     Fifth degree polynomial.  First and second derivatives zero at extrema
18919 !$$$      xsq=x*x
18920 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
18921 !$$$      deriv=x-1.0d0
18922 !$$$      deriv=deriv*deriv
18923 !$$$      deriv=30.0d0*xsq*deriv
18924
18925       return
18926       end function h_base
18927 !-----------------------------------------------------------------------------
18928       subroutine dyn_set_nss
18929 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
18930 !      implicit none
18931       use MD_data, only: totT,t_bath
18932 !     Includes
18933 !      include 'DIMENSIONS'
18934 #ifdef MPI
18935       include "mpif.h"
18936 #endif
18937 !      include 'COMMON.SBRIDGE'
18938 !      include 'COMMON.CHAIN'
18939 !      include 'COMMON.IOUNITS'
18940 !      include 'COMMON.SETUP'
18941 !      include 'COMMON.MD'
18942 !     Local variables
18943       real(kind=8) :: emin
18944       integer :: i,j,imin,ierr
18945       integer :: diff,allnss,newnss
18946       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18947             newihpb,newjhpb
18948       logical :: found
18949       integer,dimension(0:nfgtasks) :: i_newnss
18950       integer,dimension(0:nfgtasks) :: displ
18951       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18952       integer :: g_newnss
18953
18954       allnss=0
18955       do i=1,nres-1
18956       do j=i+1,nres
18957         if (dyn_ssbond_ij(i,j).lt.1.0d300) then
18958           allnss=allnss+1
18959           allflag(allnss)=0
18960           allihpb(allnss)=i
18961           alljhpb(allnss)=j
18962         endif
18963       enddo
18964       enddo
18965
18966 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18967
18968  1    emin=1.0d300
18969       do i=1,allnss
18970       if (allflag(i).eq.0 .and. &
18971            dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
18972         emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
18973         imin=i
18974       endif
18975       enddo
18976       if (emin.lt.1.0d300) then
18977       allflag(imin)=1
18978       do i=1,allnss
18979         if (allflag(i).eq.0 .and. &
18980              (allihpb(i).eq.allihpb(imin) .or. &
18981              alljhpb(i).eq.allihpb(imin) .or. &
18982              allihpb(i).eq.alljhpb(imin) .or. &
18983              alljhpb(i).eq.alljhpb(imin))) then
18984           allflag(i)=-1
18985         endif
18986       enddo
18987       goto 1
18988       endif
18989
18990 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18991
18992       newnss=0
18993       do i=1,allnss
18994       if (allflag(i).eq.1) then
18995         newnss=newnss+1
18996         newihpb(newnss)=allihpb(i)
18997         newjhpb(newnss)=alljhpb(i)
18998       endif
18999       enddo
19000
19001 #ifdef MPI
19002       if (nfgtasks.gt.1)then
19003
19004       call MPI_Reduce(newnss,g_newnss,1,&
19005         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
19006       call MPI_Gather(newnss,1,MPI_INTEGER,&
19007                   i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
19008       displ(0)=0
19009       do i=1,nfgtasks-1,1
19010         displ(i)=i_newnss(i-1)+displ(i-1)
19011       enddo
19012       call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
19013                    g_newihpb,i_newnss,displ,MPI_INTEGER,&
19014                    king,FG_COMM,IERR)
19015       call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
19016                    g_newjhpb,i_newnss,displ,MPI_INTEGER,&
19017                    king,FG_COMM,IERR)
19018       if(fg_rank.eq.0) then
19019 !         print *,'g_newnss',g_newnss
19020 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
19021 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
19022        newnss=g_newnss
19023        do i=1,newnss
19024         newihpb(i)=g_newihpb(i)
19025         newjhpb(i)=g_newjhpb(i)
19026        enddo
19027       endif
19028       endif
19029 #endif
19030
19031       diff=newnss-nss
19032
19033 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
19034 !       print *,newnss,nss,maxdim
19035       do i=1,nss
19036       found=.false.
19037 !        print *,newnss
19038       do j=1,newnss
19039 !!          print *,j
19040         if (idssb(i).eq.newihpb(j) .and. &
19041              jdssb(i).eq.newjhpb(j)) found=.true.
19042       enddo
19043 #ifndef CLUST
19044 #ifndef WHAM
19045 !        write(iout,*) "found",found,i,j
19046       if (.not.found.and.fg_rank.eq.0) &
19047           write(iout,'(a15,f12.2,f8.1,2i5)') &
19048            "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
19049 #endif
19050 #endif
19051       enddo
19052
19053       do i=1,newnss
19054       found=.false.
19055       do j=1,nss
19056 !          print *,i,j
19057         if (newihpb(i).eq.idssb(j) .and. &
19058              newjhpb(i).eq.jdssb(j)) found=.true.
19059       enddo
19060 #ifndef CLUST
19061 #ifndef WHAM
19062 !        write(iout,*) "found",found,i,j
19063       if (.not.found.and.fg_rank.eq.0) &
19064           write(iout,'(a15,f12.2,f8.1,2i5)') &
19065            "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
19066 #endif
19067 #endif
19068       enddo
19069
19070       nss=newnss
19071       do i=1,nss
19072       idssb(i)=newihpb(i)
19073       jdssb(i)=newjhpb(i)
19074       enddo
19075
19076       return
19077       end subroutine dyn_set_nss
19078 ! Lipid transfer energy function
19079       subroutine Eliptransfer(eliptran)
19080 !C this is done by Adasko
19081 !C      print *,"wchodze"
19082 !C structure of box:
19083 !C      water
19084 !C--bordliptop-- buffore starts
19085 !C--bufliptop--- here true lipid starts
19086 !C      lipid
19087 !C--buflipbot--- lipid ends buffore starts
19088 !C--bordlipbot--buffore ends
19089       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
19090       integer :: i
19091       eliptran=0.0
19092 !      print *, "I am in eliptran"
19093       do i=ilip_start,ilip_end
19094 !C       do i=1,1
19095       if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
19096        cycle
19097
19098       positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
19099       if (positi.le.0.0) positi=positi+boxzsize
19100 !C        print *,i
19101 !C first for peptide groups
19102 !c for each residue check if it is in lipid or lipid water border area
19103        if ((positi.gt.bordlipbot)  &
19104       .and.(positi.lt.bordliptop)) then
19105 !C the energy transfer exist
19106       if (positi.lt.buflipbot) then
19107 !C what fraction I am in
19108        fracinbuf=1.0d0-      &
19109            ((positi-bordlipbot)/lipbufthick)
19110 !C lipbufthick is thickenes of lipid buffore
19111        sslip=sscalelip(fracinbuf)
19112        ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19113        eliptran=eliptran+sslip*pepliptran
19114        gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19115        gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19116 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19117
19118 !C        print *,"doing sccale for lower part"
19119 !C         print *,i,sslip,fracinbuf,ssgradlip
19120       elseif (positi.gt.bufliptop) then
19121        fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
19122        sslip=sscalelip(fracinbuf)
19123        ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19124        eliptran=eliptran+sslip*pepliptran
19125        gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19126        gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19127 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19128 !C          print *, "doing sscalefor top part"
19129 !C         print *,i,sslip,fracinbuf,ssgradlip
19130       else
19131        eliptran=eliptran+pepliptran
19132 !C         print *,"I am in true lipid"
19133       endif
19134 !C       else
19135 !C       eliptran=elpitran+0.0 ! I am in water
19136        endif
19137        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
19138        enddo
19139 ! here starts the side chain transfer
19140        do i=ilip_start,ilip_end
19141       if (itype(i,1).eq.ntyp1) cycle
19142       positi=(mod(c(3,i+nres),boxzsize))
19143       if (positi.le.0) positi=positi+boxzsize
19144 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19145 !c for each residue check if it is in lipid or lipid water border area
19146 !C       respos=mod(c(3,i+nres),boxzsize)
19147 !C       print *,positi,bordlipbot,buflipbot
19148        if ((positi.gt.bordlipbot) &
19149        .and.(positi.lt.bordliptop)) then
19150 !C the energy transfer exist
19151       if (positi.lt.buflipbot) then
19152        fracinbuf=1.0d0-   &
19153          ((positi-bordlipbot)/lipbufthick)
19154 !C lipbufthick is thickenes of lipid buffore
19155        sslip=sscalelip(fracinbuf)
19156        ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19157        eliptran=eliptran+sslip*liptranene(itype(i,1))
19158        gliptranx(3,i)=gliptranx(3,i) &
19159       +ssgradlip*liptranene(itype(i,1))
19160        gliptranc(3,i-1)= gliptranc(3,i-1) &
19161       +ssgradlip*liptranene(itype(i,1))
19162 !C         print *,"doing sccale for lower part"
19163       elseif (positi.gt.bufliptop) then
19164        fracinbuf=1.0d0-  &
19165       ((bordliptop-positi)/lipbufthick)
19166        sslip=sscalelip(fracinbuf)
19167        ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19168        eliptran=eliptran+sslip*liptranene(itype(i,1))
19169        gliptranx(3,i)=gliptranx(3,i)  &
19170        +ssgradlip*liptranene(itype(i,1))
19171        gliptranc(3,i-1)= gliptranc(3,i-1) &
19172       +ssgradlip*liptranene(itype(i,1))
19173 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19174       else
19175        eliptran=eliptran+liptranene(itype(i,1))
19176 !C         print *,"I am in true lipid"
19177       endif
19178       endif ! if in lipid or buffor
19179 !C       else
19180 !C       eliptran=elpitran+0.0 ! I am in water
19181       if (energy_dec) write(iout,*) i,"eliptran=",eliptran
19182        enddo
19183        return
19184        end  subroutine Eliptransfer
19185 !----------------------------------NANO FUNCTIONS
19186 !C-----------------------------------------------------------------------
19187 !C-----------------------------------------------------------
19188 !C This subroutine is to mimic the histone like structure but as well can be
19189 !C utilizet to nanostructures (infinit) small modification has to be used to
19190 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19191 !C gradient has to be modified at the ends
19192 !C The energy function is Kihara potential
19193 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19194 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19195 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19196 !C simple Kihara potential
19197       subroutine calctube(Etube)
19198       real(kind=8),dimension(3) :: vectube
19199       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19200        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
19201        sc_aa_tube,sc_bb_tube
19202       integer :: i,j,iti
19203       Etube=0.0d0
19204       do i=itube_start,itube_end
19205       enetube(i)=0.0d0
19206       enetube(i+nres)=0.0d0
19207       enddo
19208 !C first we calculate the distance from tube center
19209 !C for UNRES
19210        do i=itube_start,itube_end
19211 !C lets ommit dummy atoms for now
19212        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19213 !C now calculate distance from center of tube and direction vectors
19214       xmin=boxxsize
19215       ymin=boxysize
19216 ! Find minimum distance in periodic box
19217       do j=-1,1
19218        vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19219        vectube(1)=vectube(1)+boxxsize*j
19220        vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19221        vectube(2)=vectube(2)+boxysize*j
19222        xminact=abs(vectube(1)-tubecenter(1))
19223        yminact=abs(vectube(2)-tubecenter(2))
19224          if (xmin.gt.xminact) then
19225           xmin=xminact
19226           xtemp=vectube(1)
19227          endif
19228          if (ymin.gt.yminact) then
19229            ymin=yminact
19230            ytemp=vectube(2)
19231           endif
19232        enddo
19233       vectube(1)=xtemp
19234       vectube(2)=ytemp
19235       vectube(1)=vectube(1)-tubecenter(1)
19236       vectube(2)=vectube(2)-tubecenter(2)
19237
19238 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19239 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19240
19241 !C as the tube is infinity we do not calculate the Z-vector use of Z
19242 !C as chosen axis
19243       vectube(3)=0.0d0
19244 !C now calculte the distance
19245        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19246 !C now normalize vector
19247       vectube(1)=vectube(1)/tub_r
19248       vectube(2)=vectube(2)/tub_r
19249 !C calculte rdiffrence between r and r0
19250       rdiff=tub_r-tubeR0
19251 !C and its 6 power
19252       rdiff6=rdiff**6.0d0
19253 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19254        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19255 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19256 !C       print *,rdiff,rdiff6,pep_aa_tube
19257 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19258 !C now we calculate gradient
19259        fac=(-12.0d0*pep_aa_tube/rdiff6- &
19260           6.0d0*pep_bb_tube)/rdiff6/rdiff
19261 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19262 !C     &rdiff,fac
19263 !C now direction of gg_tube vector
19264       do j=1,3
19265       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19266       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19267       enddo
19268       enddo
19269 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19270 !C        print *,gg_tube(1,0),"TU"
19271
19272
19273        do i=itube_start,itube_end
19274 !C Lets not jump over memory as we use many times iti
19275        iti=itype(i,1)
19276 !C lets ommit dummy atoms for now
19277        if ((iti.eq.ntyp1)  &
19278 !C in UNRES uncomment the line below as GLY has no side-chain...
19279 !C      .or.(iti.eq.10)
19280       ) cycle
19281       xmin=boxxsize
19282       ymin=boxysize
19283       do j=-1,1
19284        vectube(1)=mod((c(1,i+nres)),boxxsize)
19285        vectube(1)=vectube(1)+boxxsize*j
19286        vectube(2)=mod((c(2,i+nres)),boxysize)
19287        vectube(2)=vectube(2)+boxysize*j
19288
19289        xminact=abs(vectube(1)-tubecenter(1))
19290        yminact=abs(vectube(2)-tubecenter(2))
19291          if (xmin.gt.xminact) then
19292           xmin=xminact
19293           xtemp=vectube(1)
19294          endif
19295          if (ymin.gt.yminact) then
19296            ymin=yminact
19297            ytemp=vectube(2)
19298           endif
19299        enddo
19300       vectube(1)=xtemp
19301       vectube(2)=ytemp
19302 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19303 !C     &     tubecenter(2)
19304       vectube(1)=vectube(1)-tubecenter(1)
19305       vectube(2)=vectube(2)-tubecenter(2)
19306
19307 !C as the tube is infinity we do not calculate the Z-vector use of Z
19308 !C as chosen axis
19309       vectube(3)=0.0d0
19310 !C now calculte the distance
19311        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19312 !C now normalize vector
19313       vectube(1)=vectube(1)/tub_r
19314       vectube(2)=vectube(2)/tub_r
19315
19316 !C calculte rdiffrence between r and r0
19317       rdiff=tub_r-tubeR0
19318 !C and its 6 power
19319       rdiff6=rdiff**6.0d0
19320 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19321        sc_aa_tube=sc_aa_tube_par(iti)
19322        sc_bb_tube=sc_bb_tube_par(iti)
19323        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19324        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
19325            6.0d0*sc_bb_tube/rdiff6/rdiff
19326 !C now direction of gg_tube vector
19327        do j=1,3
19328         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19329         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19330        enddo
19331       enddo
19332       do i=itube_start,itube_end
19333         Etube=Etube+enetube(i)+enetube(i+nres)
19334       enddo
19335 !C        print *,"ETUBE", etube
19336       return
19337       end subroutine calctube
19338 !C TO DO 1) add to total energy
19339 !C       2) add to gradient summation
19340 !C       3) add reading parameters (AND of course oppening of PARAM file)
19341 !C       4) add reading the center of tube
19342 !C       5) add COMMONs
19343 !C       6) add to zerograd
19344 !C       7) allocate matrices
19345
19346
19347 !C-----------------------------------------------------------------------
19348 !C-----------------------------------------------------------
19349 !C This subroutine is to mimic the histone like structure but as well can be
19350 !C utilizet to nanostructures (infinit) small modification has to be used to
19351 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19352 !C gradient has to be modified at the ends
19353 !C The energy function is Kihara potential
19354 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19355 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19356 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19357 !C simple Kihara potential
19358       subroutine calctube2(Etube)
19359           real(kind=8),dimension(3) :: vectube
19360       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19361        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
19362        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
19363       integer:: i,j,iti
19364       Etube=0.0d0
19365       do i=itube_start,itube_end
19366       enetube(i)=0.0d0
19367       enetube(i+nres)=0.0d0
19368       enddo
19369 !C first we calculate the distance from tube center
19370 !C first sugare-phosphate group for NARES this would be peptide group
19371 !C for UNRES
19372        do i=itube_start,itube_end
19373 !C lets ommit dummy atoms for now
19374
19375        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19376 !C now calculate distance from center of tube and direction vectors
19377 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19378 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19379 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19380 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19381       xmin=boxxsize
19382       ymin=boxysize
19383       do j=-1,1
19384        vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19385        vectube(1)=vectube(1)+boxxsize*j
19386        vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19387        vectube(2)=vectube(2)+boxysize*j
19388
19389        xminact=abs(vectube(1)-tubecenter(1))
19390        yminact=abs(vectube(2)-tubecenter(2))
19391          if (xmin.gt.xminact) then
19392           xmin=xminact
19393           xtemp=vectube(1)
19394          endif
19395          if (ymin.gt.yminact) then
19396            ymin=yminact
19397            ytemp=vectube(2)
19398           endif
19399        enddo
19400       vectube(1)=xtemp
19401       vectube(2)=ytemp
19402       vectube(1)=vectube(1)-tubecenter(1)
19403       vectube(2)=vectube(2)-tubecenter(2)
19404
19405 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19406 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19407
19408 !C as the tube is infinity we do not calculate the Z-vector use of Z
19409 !C as chosen axis
19410       vectube(3)=0.0d0
19411 !C now calculte the distance
19412        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19413 !C now normalize vector
19414       vectube(1)=vectube(1)/tub_r
19415       vectube(2)=vectube(2)/tub_r
19416 !C calculte rdiffrence between r and r0
19417       rdiff=tub_r-tubeR0
19418 !C and its 6 power
19419       rdiff6=rdiff**6.0d0
19420 !C THIS FRAGMENT MAKES TUBE FINITE
19421       positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19422       if (positi.le.0) positi=positi+boxzsize
19423 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19424 !c for each residue check if it is in lipid or lipid water border area
19425 !C       respos=mod(c(3,i+nres),boxzsize)
19426 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19427        if ((positi.gt.bordtubebot)  &
19428       .and.(positi.lt.bordtubetop)) then
19429 !C the energy transfer exist
19430       if (positi.lt.buftubebot) then
19431        fracinbuf=1.0d0-  &
19432          ((positi-bordtubebot)/tubebufthick)
19433 !C lipbufthick is thickenes of lipid buffore
19434        sstube=sscalelip(fracinbuf)
19435        ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19436 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19437        enetube(i)=enetube(i)+sstube*tubetranenepep
19438 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19439 !C     &+ssgradtube*tubetranene(itype(i,1))
19440 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19441 !C     &+ssgradtube*tubetranene(itype(i,1))
19442 !C         print *,"doing sccale for lower part"
19443       elseif (positi.gt.buftubetop) then
19444        fracinbuf=1.0d0-  &
19445       ((bordtubetop-positi)/tubebufthick)
19446        sstube=sscalelip(fracinbuf)
19447        ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19448        enetube(i)=enetube(i)+sstube*tubetranenepep
19449 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19450 !C     &+ssgradtube*tubetranene(itype(i,1))
19451 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19452 !C     &+ssgradtube*tubetranene(itype(i,1))
19453 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19454       else
19455        sstube=1.0d0
19456        ssgradtube=0.0d0
19457        enetube(i)=enetube(i)+sstube*tubetranenepep
19458 !C         print *,"I am in true lipid"
19459       endif
19460       else
19461 !C          sstube=0.0d0
19462 !C          ssgradtube=0.0d0
19463       cycle
19464       endif ! if in lipid or buffor
19465
19466 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19467        enetube(i)=enetube(i)+sstube* &
19468       (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
19469 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19470 !C       print *,rdiff,rdiff6,pep_aa_tube
19471 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19472 !C now we calculate gradient
19473        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
19474            6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
19475 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19476 !C     &rdiff,fac
19477
19478 !C now direction of gg_tube vector
19479        do j=1,3
19480       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19481       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19482       enddo
19483        gg_tube(3,i)=gg_tube(3,i)  &
19484        +ssgradtube*enetube(i)/sstube/2.0d0
19485        gg_tube(3,i-1)= gg_tube(3,i-1)  &
19486        +ssgradtube*enetube(i)/sstube/2.0d0
19487
19488       enddo
19489 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19490 !C        print *,gg_tube(1,0),"TU"
19491       do i=itube_start,itube_end
19492 !C Lets not jump over memory as we use many times iti
19493        iti=itype(i,1)
19494 !C lets ommit dummy atoms for now
19495        if ((iti.eq.ntyp1) &
19496 !!C in UNRES uncomment the line below as GLY has no side-chain...
19497          .or.(iti.eq.10) &
19498         ) cycle
19499         vectube(1)=c(1,i+nres)
19500         vectube(1)=mod(vectube(1),boxxsize)
19501         if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19502         vectube(2)=c(2,i+nres)
19503         vectube(2)=mod(vectube(2),boxysize)
19504         if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19505
19506       vectube(1)=vectube(1)-tubecenter(1)
19507       vectube(2)=vectube(2)-tubecenter(2)
19508 !C THIS FRAGMENT MAKES TUBE FINITE
19509       positi=(mod(c(3,i+nres),boxzsize))
19510       if (positi.le.0) positi=positi+boxzsize
19511 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19512 !c for each residue check if it is in lipid or lipid water border area
19513 !C       respos=mod(c(3,i+nres),boxzsize)
19514 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19515
19516        if ((positi.gt.bordtubebot)  &
19517       .and.(positi.lt.bordtubetop)) then
19518 !C the energy transfer exist
19519       if (positi.lt.buftubebot) then
19520        fracinbuf=1.0d0- &
19521           ((positi-bordtubebot)/tubebufthick)
19522 !C lipbufthick is thickenes of lipid buffore
19523        sstube=sscalelip(fracinbuf)
19524        ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19525 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19526        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19527 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19528 !C     &+ssgradtube*tubetranene(itype(i,1))
19529 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19530 !C     &+ssgradtube*tubetranene(itype(i,1))
19531 !C         print *,"doing sccale for lower part"
19532       elseif (positi.gt.buftubetop) then
19533        fracinbuf=1.0d0- &
19534       ((bordtubetop-positi)/tubebufthick)
19535
19536        sstube=sscalelip(fracinbuf)
19537        ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19538        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19539 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19540 !C     &+ssgradtube*tubetranene(itype(i,1))
19541 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19542 !C     &+ssgradtube*tubetranene(itype(i,1))
19543 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19544       else
19545        sstube=1.0d0
19546        ssgradtube=0.0d0
19547        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19548 !C         print *,"I am in true lipid"
19549       endif
19550       else
19551 !C          sstube=0.0d0
19552 !C          ssgradtube=0.0d0
19553       cycle
19554       endif ! if in lipid or buffor
19555 !CEND OF FINITE FRAGMENT
19556 !C as the tube is infinity we do not calculate the Z-vector use of Z
19557 !C as chosen axis
19558       vectube(3)=0.0d0
19559 !C now calculte the distance
19560        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19561 !C now normalize vector
19562       vectube(1)=vectube(1)/tub_r
19563       vectube(2)=vectube(2)/tub_r
19564 !C calculte rdiffrence between r and r0
19565       rdiff=tub_r-tubeR0
19566 !C and its 6 power
19567       rdiff6=rdiff**6.0d0
19568 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19569        sc_aa_tube=sc_aa_tube_par(iti)
19570        sc_bb_tube=sc_bb_tube_par(iti)
19571        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
19572                    *sstube+enetube(i+nres)
19573 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19574 !C now we calculate gradient
19575        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
19576           6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
19577 !C now direction of gg_tube vector
19578        do j=1,3
19579         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19580         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19581        enddo
19582        gg_tube_SC(3,i)=gg_tube_SC(3,i) &
19583        +ssgradtube*enetube(i+nres)/sstube
19584        gg_tube(3,i-1)= gg_tube(3,i-1) &
19585        +ssgradtube*enetube(i+nres)/sstube
19586
19587       enddo
19588       do i=itube_start,itube_end
19589         Etube=Etube+enetube(i)+enetube(i+nres)
19590       enddo
19591 !C        print *,"ETUBE", etube
19592       return
19593       end subroutine calctube2
19594 !=====================================================================================================================================
19595       subroutine calcnano(Etube)
19596       real(kind=8),dimension(3) :: vectube
19597
19598       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19599        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
19600        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
19601        integer:: i,j,iti,r
19602
19603       Etube=0.0d0
19604 !      print *,itube_start,itube_end,"poczatek"
19605       do i=itube_start,itube_end
19606       enetube(i)=0.0d0
19607       enetube(i+nres)=0.0d0
19608       enddo
19609 !C first we calculate the distance from tube center
19610 !C first sugare-phosphate group for NARES this would be peptide group
19611 !C for UNRES
19612        do i=itube_start,itube_end
19613 !C lets ommit dummy atoms for now
19614        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19615 !C now calculate distance from center of tube and direction vectors
19616       xmin=boxxsize
19617       ymin=boxysize
19618       zmin=boxzsize
19619
19620       do j=-1,1
19621        vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19622        vectube(1)=vectube(1)+boxxsize*j
19623        vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19624        vectube(2)=vectube(2)+boxysize*j
19625        vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19626        vectube(3)=vectube(3)+boxzsize*j
19627
19628
19629        xminact=dabs(vectube(1)-tubecenter(1))
19630        yminact=dabs(vectube(2)-tubecenter(2))
19631        zminact=dabs(vectube(3)-tubecenter(3))
19632
19633          if (xmin.gt.xminact) then
19634           xmin=xminact
19635           xtemp=vectube(1)
19636          endif
19637          if (ymin.gt.yminact) then
19638            ymin=yminact
19639            ytemp=vectube(2)
19640           endif
19641          if (zmin.gt.zminact) then
19642            zmin=zminact
19643            ztemp=vectube(3)
19644           endif
19645        enddo
19646       vectube(1)=xtemp
19647       vectube(2)=ytemp
19648       vectube(3)=ztemp
19649
19650       vectube(1)=vectube(1)-tubecenter(1)
19651       vectube(2)=vectube(2)-tubecenter(2)
19652       vectube(3)=vectube(3)-tubecenter(3)
19653
19654 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19655 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19656 !C as the tube is infinity we do not calculate the Z-vector use of Z
19657 !C as chosen axis
19658 !C      vectube(3)=0.0d0
19659 !C now calculte the distance
19660        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19661 !C now normalize vector
19662       vectube(1)=vectube(1)/tub_r
19663       vectube(2)=vectube(2)/tub_r
19664       vectube(3)=vectube(3)/tub_r
19665 !C calculte rdiffrence between r and r0
19666       rdiff=tub_r-tubeR0
19667 !C and its 6 power
19668       rdiff6=rdiff**6.0d0
19669 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19670        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19671 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19672 !C       print *,rdiff,rdiff6,pep_aa_tube
19673 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19674 !C now we calculate gradient
19675        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
19676           6.0d0*pep_bb_tube)/rdiff6/rdiff
19677 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19678 !C     &rdiff,fac
19679        if (acavtubpep.eq.0.0d0) then
19680 !C go to 667
19681        enecavtube(i)=0.0
19682        faccav=0.0
19683        else
19684        denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
19685        enecavtube(i)=  &
19686       (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
19687       /denominator
19688        enecavtube(i)=0.0
19689        faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
19690       *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
19691       +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
19692       /denominator**2.0d0
19693 !C         faccav=0.0
19694 !C         fac=fac+faccav
19695 !C 667     continue
19696        endif
19697         if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
19698       do j=1,3
19699       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19700       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19701       enddo
19702       enddo
19703
19704        do i=itube_start,itube_end
19705       enecavtube(i)=0.0d0
19706 !C Lets not jump over memory as we use many times iti
19707        iti=itype(i,1)
19708 !C lets ommit dummy atoms for now
19709        if ((iti.eq.ntyp1) &
19710 !C in UNRES uncomment the line below as GLY has no side-chain...
19711 !C      .or.(iti.eq.10)
19712        ) cycle
19713       xmin=boxxsize
19714       ymin=boxysize
19715       zmin=boxzsize
19716       do j=-1,1
19717        vectube(1)=dmod((c(1,i+nres)),boxxsize)
19718        vectube(1)=vectube(1)+boxxsize*j
19719        vectube(2)=dmod((c(2,i+nres)),boxysize)
19720        vectube(2)=vectube(2)+boxysize*j
19721        vectube(3)=dmod((c(3,i+nres)),boxzsize)
19722        vectube(3)=vectube(3)+boxzsize*j
19723
19724
19725        xminact=dabs(vectube(1)-tubecenter(1))
19726        yminact=dabs(vectube(2)-tubecenter(2))
19727        zminact=dabs(vectube(3)-tubecenter(3))
19728
19729          if (xmin.gt.xminact) then
19730           xmin=xminact
19731           xtemp=vectube(1)
19732          endif
19733          if (ymin.gt.yminact) then
19734            ymin=yminact
19735            ytemp=vectube(2)
19736           endif
19737          if (zmin.gt.zminact) then
19738            zmin=zminact
19739            ztemp=vectube(3)
19740           endif
19741        enddo
19742       vectube(1)=xtemp
19743       vectube(2)=ytemp
19744       vectube(3)=ztemp
19745
19746 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19747 !C     &     tubecenter(2)
19748       vectube(1)=vectube(1)-tubecenter(1)
19749       vectube(2)=vectube(2)-tubecenter(2)
19750       vectube(3)=vectube(3)-tubecenter(3)
19751 !C now calculte the distance
19752        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19753 !C now normalize vector
19754       vectube(1)=vectube(1)/tub_r
19755       vectube(2)=vectube(2)/tub_r
19756       vectube(3)=vectube(3)/tub_r
19757
19758 !C calculte rdiffrence between r and r0
19759       rdiff=tub_r-tubeR0
19760 !C and its 6 power
19761       rdiff6=rdiff**6.0d0
19762        sc_aa_tube=sc_aa_tube_par(iti)
19763        sc_bb_tube=sc_bb_tube_par(iti)
19764        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19765 !C       enetube(i+nres)=0.0d0
19766 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19767 !C now we calculate gradient
19768        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
19769           6.0d0*sc_bb_tube/rdiff6/rdiff
19770 !C       fac=0.0
19771 !C now direction of gg_tube vector
19772 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
19773        if (acavtub(iti).eq.0.0d0) then
19774 !C go to 667
19775        enecavtube(i+nres)=0.0d0
19776        faccav=0.0d0
19777        else
19778        denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
19779        enecavtube(i+nres)=   &
19780       (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
19781       /denominator
19782 !C         enecavtube(i)=0.0
19783        faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
19784       *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
19785       +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
19786       /denominator**2.0d0
19787 !C         faccav=0.0
19788        fac=fac+faccav
19789 !C 667     continue
19790        endif
19791 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
19792 !C     &   enecavtube(i),faccav
19793 !C         print *,"licz=",
19794 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
19795 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
19796        do j=1,3
19797         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19798         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19799        enddo
19800         if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
19801       enddo
19802
19803
19804
19805       do i=itube_start,itube_end
19806         Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
19807        +enecavtube(i+nres)
19808       enddo
19809 !        do i=1,20
19810 !         print *,"begin", i,"a"
19811 !         do r=1,10000
19812 !          rdiff=r/100.0d0
19813 !          rdiff6=rdiff**6.0d0
19814 !          sc_aa_tube=sc_aa_tube_par(i)
19815 !          sc_bb_tube=sc_bb_tube_par(i)
19816 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19817 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
19818 !          enecavtube(i)=   &
19819 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
19820 !         /denominator
19821
19822 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
19823 !         enddo
19824 !         print *,"end",i,"a"
19825 !        enddo
19826 !C        print *,"ETUBE", etube
19827       return
19828       end subroutine calcnano
19829
19830 !===============================================
19831 !--------------------------------------------------------------------------------
19832 !C first for shielding is setting of function of side-chains
19833
19834        subroutine set_shield_fac2
19835        real(kind=8) :: div77_81=0.974996043d0, &
19836       div4_81=0.2222222222d0
19837        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
19838        scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
19839        short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
19840        sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
19841 !C the vector between center of side_chain and peptide group
19842        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
19843        pept_group,costhet_grad,cosphi_grad_long, &
19844        cosphi_grad_loc,pep_side_norm,side_calf_norm, &
19845        sh_frac_dist_grad,pep_side
19846       integer i,j,k
19847 !C      write(2,*) "ivec",ivec_start,ivec_end
19848       do i=1,nres
19849       fac_shield(i)=0.0d0
19850       ishield_list(i)=0
19851       do j=1,3
19852       grad_shield(j,i)=0.0d0
19853       enddo
19854       enddo
19855       do i=ivec_start,ivec_end
19856 !C      do i=1,nres-1
19857 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19858 !      ishield_list(i)=0
19859       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19860 !Cif there two consequtive dummy atoms there is no peptide group between them
19861 !C the line below has to be changed for FGPROC>1
19862       VolumeTotal=0.0
19863       do k=1,nres
19864        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
19865        dist_pep_side=0.0
19866        dist_side_calf=0.0
19867        do j=1,3
19868 !C first lets set vector conecting the ithe side-chain with kth side-chain
19869       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
19870 !C      pep_side(j)=2.0d0
19871 !C and vector conecting the side-chain with its proper calfa
19872       side_calf(j)=c(j,k+nres)-c(j,k)
19873 !C      side_calf(j)=2.0d0
19874       pept_group(j)=c(j,i)-c(j,i+1)
19875 !C lets have their lenght
19876       dist_pep_side=pep_side(j)**2+dist_pep_side
19877       dist_side_calf=dist_side_calf+side_calf(j)**2
19878       dist_pept_group=dist_pept_group+pept_group(j)**2
19879       enddo
19880        dist_pep_side=sqrt(dist_pep_side)
19881        dist_pept_group=sqrt(dist_pept_group)
19882        dist_side_calf=sqrt(dist_side_calf)
19883       do j=1,3
19884       pep_side_norm(j)=pep_side(j)/dist_pep_side
19885       side_calf_norm(j)=dist_side_calf
19886       enddo
19887 !C now sscale fraction
19888        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
19889 !       print *,buff_shield,"buff",sh_frac_dist
19890 !C now sscale
19891       if (sh_frac_dist.le.0.0) cycle
19892 !C        print *,ishield_list(i),i
19893 !C If we reach here it means that this side chain reaches the shielding sphere
19894 !C Lets add him to the list for gradient
19895       ishield_list(i)=ishield_list(i)+1
19896 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
19897 !C this list is essential otherwise problem would be O3
19898       shield_list(ishield_list(i),i)=k
19899 !C Lets have the sscale value
19900       if (sh_frac_dist.gt.1.0) then
19901        scale_fac_dist=1.0d0
19902        do j=1,3
19903        sh_frac_dist_grad(j)=0.0d0
19904        enddo
19905       else
19906        scale_fac_dist=-sh_frac_dist*sh_frac_dist &
19907                   *(2.0d0*sh_frac_dist-3.0d0)
19908        fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
19909                    /dist_pep_side/buff_shield*0.5d0
19910        do j=1,3
19911        sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
19912 !C         sh_frac_dist_grad(j)=0.0d0
19913 !C         scale_fac_dist=1.0d0
19914 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
19915 !C     &                    sh_frac_dist_grad(j)
19916        enddo
19917       endif
19918 !C this is what is now we have the distance scaling now volume...
19919       short=short_r_sidechain(itype(k,1))
19920       long=long_r_sidechain(itype(k,1))
19921       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
19922       sinthet=short/dist_pep_side*costhet
19923 !      print *,"SORT",short,long,sinthet,costhet
19924 !C now costhet_grad
19925 !C       costhet=0.6d0
19926 !C       sinthet=0.8
19927        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
19928 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
19929 !C     &             -short/dist_pep_side**2/costhet)
19930 !C       costhet_fac=0.0d0
19931        do j=1,3
19932        costhet_grad(j)=costhet_fac*pep_side(j)
19933        enddo
19934 !C remember for the final gradient multiply costhet_grad(j)
19935 !C for side_chain by factor -2 !
19936 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
19937 !C pep_side0pept_group is vector multiplication
19938       pep_side0pept_group=0.0d0
19939       do j=1,3
19940       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
19941       enddo
19942       cosalfa=(pep_side0pept_group/ &
19943       (dist_pep_side*dist_side_calf))
19944       fac_alfa_sin=1.0d0-cosalfa**2
19945       fac_alfa_sin=dsqrt(fac_alfa_sin)
19946       rkprim=fac_alfa_sin*(long-short)+short
19947 !C      rkprim=short
19948
19949 !C now costhet_grad
19950        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
19951 !C       cosphi=0.6
19952        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
19953        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
19954          dist_pep_side**2)
19955 !C       sinphi=0.8
19956        do j=1,3
19957        cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
19958       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19959       *(long-short)/fac_alfa_sin*cosalfa/ &
19960       ((dist_pep_side*dist_side_calf))* &
19961       ((side_calf(j))-cosalfa* &
19962       ((pep_side(j)/dist_pep_side)*dist_side_calf))
19963 !C       cosphi_grad_long(j)=0.0d0
19964       cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19965       *(long-short)/fac_alfa_sin*cosalfa &
19966       /((dist_pep_side*dist_side_calf))* &
19967       (pep_side(j)- &
19968       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
19969 !C       cosphi_grad_loc(j)=0.0d0
19970        enddo
19971 !C      print *,sinphi,sinthet
19972       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
19973                    /VSolvSphere_div
19974 !C     &                    *wshield
19975 !C now the gradient...
19976       do j=1,3
19977       grad_shield(j,i)=grad_shield(j,i) &
19978 !C gradient po skalowaniu
19979                  +(sh_frac_dist_grad(j)*VofOverlap &
19980 !C  gradient po costhet
19981           +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
19982       (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
19983           sinphi/sinthet*costhet*costhet_grad(j) &
19984          +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19985       )*wshield
19986 !C grad_shield_side is Cbeta sidechain gradient
19987       grad_shield_side(j,ishield_list(i),i)=&
19988            (sh_frac_dist_grad(j)*-2.0d0&
19989            *VofOverlap&
19990           -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19991        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
19992           sinphi/sinthet*costhet*costhet_grad(j)&
19993          +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19994           )*wshield
19995 !       print *, 1.0d0/(-dsqrt(1.0d0-sinphi*sinthet)),&
19996 !            sinphi/sinthet,&
19997 !           +sinthet/sinphi,"HERE"
19998        grad_shield_loc(j,ishield_list(i),i)=   &
19999           scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20000       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
20001           sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
20002            ))&
20003            *wshield
20004 !         print *,grad_shield_loc(j,ishield_list(i),i)
20005       enddo
20006       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
20007       enddo
20008       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
20009
20010 !      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
20011       enddo
20012       return
20013       end subroutine set_shield_fac2
20014 !----------------------------------------------------------------------------
20015 ! SOUBROUTINE FOR AFM
20016        subroutine AFMvel(Eafmforce)
20017        use MD_data, only:totTafm
20018       real(kind=8),dimension(3) :: diffafm
20019       real(kind=8) :: afmdist,Eafmforce
20020        integer :: i
20021 !C Only for check grad COMMENT if not used for checkgrad
20022 !C      totT=3.0d0
20023 !C--------------------------------------------------------
20024 !C      print *,"wchodze"
20025       afmdist=0.0d0
20026       Eafmforce=0.0d0
20027       do i=1,3
20028       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20029       afmdist=afmdist+diffafm(i)**2
20030       enddo
20031       afmdist=dsqrt(afmdist)
20032 !      totTafm=3.0
20033       Eafmforce=0.5d0*forceAFMconst &
20034       *(distafminit+totTafm*velAFMconst-afmdist)**2
20035 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
20036       do i=1,3
20037       gradafm(i,afmend-1)=-forceAFMconst* &
20038        (distafminit+totTafm*velAFMconst-afmdist) &
20039        *diffafm(i)/afmdist
20040       gradafm(i,afmbeg-1)=forceAFMconst* &
20041       (distafminit+totTafm*velAFMconst-afmdist) &
20042       *diffafm(i)/afmdist
20043       enddo
20044 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
20045       return
20046       end subroutine AFMvel
20047 !---------------------------------------------------------
20048        subroutine AFMforce(Eafmforce)
20049
20050       real(kind=8),dimension(3) :: diffafm
20051 !      real(kind=8) ::afmdist
20052       real(kind=8) :: afmdist,Eafmforce
20053       integer :: i
20054       afmdist=0.0d0
20055       Eafmforce=0.0d0
20056       do i=1,3
20057       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20058       afmdist=afmdist+diffafm(i)**2
20059       enddo
20060       afmdist=dsqrt(afmdist)
20061 !      print *,afmdist,distafminit
20062       Eafmforce=-forceAFMconst*(afmdist-distafminit)
20063       do i=1,3
20064       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
20065       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
20066       enddo
20067 !C      print *,'AFM',Eafmforce
20068       return
20069       end subroutine AFMforce
20070
20071 !-----------------------------------------------------------------------------
20072 #ifdef WHAM
20073       subroutine read_ssHist
20074 !      implicit none
20075 !      Includes
20076 !      include 'DIMENSIONS'
20077 !      include "DIMENSIONS.FREE"
20078 !      include 'COMMON.FREE'
20079 !     Local variables
20080       integer :: i,j
20081       character(len=80) :: controlcard
20082
20083       do i=1,dyn_nssHist
20084       call card_concat(controlcard,.true.)
20085       read(controlcard,*) &
20086            dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
20087       enddo
20088
20089       return
20090       end subroutine read_ssHist
20091 #endif
20092 !-----------------------------------------------------------------------------
20093       integer function indmat(i,j)
20094 !el
20095 ! get the position of the jth ijth fragment of the chain coordinate system
20096 ! in the fromto array.
20097       integer :: i,j
20098
20099       indmat=((2*(nres-2)-i)*(i-1))/2+j-1
20100       return
20101       end function indmat
20102 !-----------------------------------------------------------------------------
20103       real(kind=8) function sigm(x)
20104 !el
20105        real(kind=8) :: x
20106       sigm=0.25d0*x
20107       return
20108       end function sigm
20109 !-----------------------------------------------------------------------------
20110 !-----------------------------------------------------------------------------
20111       subroutine alloc_ener_arrays
20112 !EL Allocation of arrays used by module energy
20113       use MD_data, only: mset
20114 !el local variables
20115       integer :: i,j
20116
20117       if(nres.lt.100) then
20118       maxconts=10*nres
20119       elseif(nres.lt.200) then
20120       maxconts=10*nres      ! Max. number of contacts per residue
20121       else
20122       maxconts=10*nres ! (maxconts=maxres/4)
20123       endif
20124       maxcont=12*nres      ! Max. number of SC contacts
20125       maxvar=6*nres      ! Max. number of variables
20126 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20127       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20128 !----------------------
20129 ! arrays in subroutine init_int_table
20130 !el#ifdef MPI
20131 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
20132 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
20133 !el#endif
20134       allocate(nint_gr(nres))
20135       allocate(nscp_gr(nres))
20136       allocate(ielstart(nres))
20137       allocate(ielend(nres))
20138 !(maxres)
20139       allocate(istart(nres,maxint_gr))
20140       allocate(iend(nres,maxint_gr))
20141 !(maxres,maxint_gr)
20142       allocate(iscpstart(nres,maxint_gr))
20143       allocate(iscpend(nres,maxint_gr))
20144 !(maxres,maxint_gr)
20145       allocate(ielstart_vdw(nres))
20146       allocate(ielend_vdw(nres))
20147 !(maxres)
20148       allocate(nint_gr_nucl(nres))
20149       allocate(nscp_gr_nucl(nres))
20150       allocate(ielstart_nucl(nres))
20151       allocate(ielend_nucl(nres))
20152 !(maxres)
20153       allocate(istart_nucl(nres,maxint_gr))
20154       allocate(iend_nucl(nres,maxint_gr))
20155 !(maxres,maxint_gr)
20156       allocate(iscpstart_nucl(nres,maxint_gr))
20157       allocate(iscpend_nucl(nres,maxint_gr))
20158 !(maxres,maxint_gr)
20159       allocate(ielstart_vdw_nucl(nres))
20160       allocate(ielend_vdw_nucl(nres))
20161
20162       allocate(lentyp(0:nfgtasks-1))
20163 !(0:maxprocs-1)
20164 !----------------------
20165 ! commom.contacts
20166 !      common /contacts/
20167       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
20168       allocate(icont(2,maxcont))
20169 !(2,maxcont)
20170 !      common /contacts1/
20171       allocate(num_cont(0:nres+4))
20172 !(maxres)
20173       allocate(jcont(maxconts,nres))
20174 !(maxconts,maxres)
20175       allocate(facont(maxconts,nres))
20176 !(maxconts,maxres)
20177       allocate(gacont(3,maxconts,nres))
20178 !(3,maxconts,maxres)
20179 !      common /contacts_hb/
20180       allocate(gacontp_hb1(3,maxconts,nres))
20181       allocate(gacontp_hb2(3,maxconts,nres))
20182       allocate(gacontp_hb3(3,maxconts,nres))
20183       allocate(gacontm_hb1(3,maxconts,nres))
20184       allocate(gacontm_hb2(3,maxconts,nres))
20185       allocate(gacontm_hb3(3,maxconts,nres))
20186       allocate(gacont_hbr(3,maxconts,nres))
20187       allocate(grij_hb_cont(3,maxconts,nres))
20188 !(3,maxconts,maxres)
20189       allocate(facont_hb(maxconts,nres))
20190
20191       allocate(ees0p(maxconts,nres))
20192       allocate(ees0m(maxconts,nres))
20193       allocate(d_cont(maxconts,nres))
20194       allocate(ees0plist(maxconts,nres))
20195
20196 !(maxconts,maxres)
20197       allocate(num_cont_hb(nres))
20198 !(maxres)
20199       allocate(jcont_hb(maxconts,nres))
20200 !(maxconts,maxres)
20201 !      common /rotat/
20202       allocate(Ug(2,2,nres))
20203       allocate(Ugder(2,2,nres))
20204       allocate(Ug2(2,2,nres))
20205       allocate(Ug2der(2,2,nres))
20206 !(2,2,maxres)
20207       allocate(obrot(2,nres))
20208       allocate(obrot2(2,nres))
20209       allocate(obrot_der(2,nres))
20210       allocate(obrot2_der(2,nres))
20211 !(2,maxres)
20212 !      common /precomp1/
20213       allocate(mu(2,nres))
20214       allocate(muder(2,nres))
20215       allocate(Ub2(2,nres))
20216       Ub2(1,:)=0.0d0
20217       Ub2(2,:)=0.0d0
20218       allocate(Ub2der(2,nres))
20219       allocate(Ctobr(2,nres))
20220       allocate(Ctobrder(2,nres))
20221       allocate(Dtobr2(2,nres))
20222       allocate(Dtobr2der(2,nres))
20223 !(2,maxres)
20224       allocate(EUg(2,2,nres))
20225       allocate(EUgder(2,2,nres))
20226       allocate(CUg(2,2,nres))
20227       allocate(CUgder(2,2,nres))
20228       allocate(DUg(2,2,nres))
20229       allocate(Dugder(2,2,nres))
20230       allocate(DtUg2(2,2,nres))
20231       allocate(DtUg2der(2,2,nres))
20232 !(2,2,maxres)
20233 !      common /precomp2/
20234       allocate(Ug2Db1t(2,nres))
20235       allocate(Ug2Db1tder(2,nres))
20236       allocate(CUgb2(2,nres))
20237       allocate(CUgb2der(2,nres))
20238 !(2,maxres)
20239       allocate(EUgC(2,2,nres))
20240       allocate(EUgCder(2,2,nres))
20241       allocate(EUgD(2,2,nres))
20242       allocate(EUgDder(2,2,nres))
20243       allocate(DtUg2EUg(2,2,nres))
20244       allocate(Ug2DtEUg(2,2,nres))
20245 !(2,2,maxres)
20246       allocate(Ug2DtEUgder(2,2,2,nres))
20247       allocate(DtUg2EUgder(2,2,2,nres))
20248 !(2,2,2,maxres)
20249       allocate(b1(2,nres))      !(2,-maxtor:maxtor)
20250       allocate(b2(2,nres))      !(2,-maxtor:maxtor)
20251       allocate(b1tilde(2,nres)) !(2,-maxtor:maxtor)
20252       allocate(b2tilde(2,nres)) !(2,-maxtor:maxtor)
20253
20254       allocate(ctilde(2,2,nres))
20255       allocate(dtilde(2,2,nres)) !(2,2,-maxtor:maxtor)
20256       allocate(gtb1(2,nres))
20257       allocate(gtb2(2,nres))
20258       allocate(cc(2,2,nres))
20259       allocate(dd(2,2,nres))
20260       allocate(ee(2,2,nres))
20261       allocate(gtcc(2,2,nres))
20262       allocate(gtdd(2,2,nres))
20263       allocate(gtee(2,2,nres))
20264       allocate(gUb2(2,nres))
20265       allocate(gteUg(2,2,nres))
20266
20267 !      common /rotat_old/
20268       allocate(costab(nres))
20269       allocate(sintab(nres))
20270       allocate(costab2(nres))
20271       allocate(sintab2(nres))
20272 !(maxres)
20273 !      common /dipmat/
20274       allocate(a_chuj(2,2,maxconts,nres))
20275 !(2,2,maxconts,maxres)(maxconts=maxres/4)
20276       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
20277 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
20278 !      common /contdistrib/
20279       allocate(ncont_sent(nres))
20280       allocate(ncont_recv(nres))
20281
20282       allocate(iat_sent(nres))
20283 !(maxres)
20284       allocate(iint_sent(4,nres,nres))
20285       allocate(iint_sent_local(4,nres,nres))
20286 !(4,maxres,maxres)
20287       allocate(iturn3_sent(4,0:nres+4))
20288       allocate(iturn4_sent(4,0:nres+4))
20289       allocate(iturn3_sent_local(4,nres))
20290       allocate(iturn4_sent_local(4,nres))
20291 !(4,maxres)
20292       allocate(itask_cont_from(0:nfgtasks-1))
20293       allocate(itask_cont_to(0:nfgtasks-1))
20294 !(0:max_fg_procs-1)
20295
20296
20297
20298 !----------------------
20299 ! commom.deriv;
20300 !      common /derivat/
20301       allocate(dcdv(6,maxdim))
20302       allocate(dxdv(6,maxdim))
20303 !(6,maxdim)
20304       allocate(dxds(6,nres))
20305 !(6,maxres)
20306       allocate(gradx(3,-1:nres,0:2))
20307       allocate(gradc(3,-1:nres,0:2))
20308 !(3,maxres,2)
20309       allocate(gvdwx(3,-1:nres))
20310       allocate(gvdwc(3,-1:nres))
20311       allocate(gelc(3,-1:nres))
20312       allocate(gelc_long(3,-1:nres))
20313       allocate(gvdwpp(3,-1:nres))
20314       allocate(gvdwc_scpp(3,-1:nres))
20315       allocate(gradx_scp(3,-1:nres))
20316       allocate(gvdwc_scp(3,-1:nres))
20317       allocate(ghpbx(3,-1:nres))
20318       allocate(ghpbc(3,-1:nres))
20319       allocate(gradcorr(3,-1:nres))
20320       allocate(gradcorr_long(3,-1:nres))
20321       allocate(gradcorr5_long(3,-1:nres))
20322       allocate(gradcorr6_long(3,-1:nres))
20323       allocate(gcorr6_turn_long(3,-1:nres))
20324       allocate(gradxorr(3,-1:nres))
20325       allocate(gradcorr5(3,-1:nres))
20326       allocate(gradcorr6(3,-1:nres))
20327       allocate(gliptran(3,-1:nres))
20328       allocate(gliptranc(3,-1:nres))
20329       allocate(gliptranx(3,-1:nres))
20330       allocate(gshieldx(3,-1:nres))
20331       allocate(gshieldc(3,-1:nres))
20332       allocate(gshieldc_loc(3,-1:nres))
20333       allocate(gshieldx_ec(3,-1:nres))
20334       allocate(gshieldc_ec(3,-1:nres))
20335       allocate(gshieldc_loc_ec(3,-1:nres))
20336       allocate(gshieldx_t3(3,-1:nres))
20337       allocate(gshieldc_t3(3,-1:nres))
20338       allocate(gshieldc_loc_t3(3,-1:nres))
20339       allocate(gshieldx_t4(3,-1:nres))
20340       allocate(gshieldc_t4(3,-1:nres))
20341       allocate(gshieldc_loc_t4(3,-1:nres))
20342       allocate(gshieldx_ll(3,-1:nres))
20343       allocate(gshieldc_ll(3,-1:nres))
20344       allocate(gshieldc_loc_ll(3,-1:nres))
20345       allocate(grad_shield(3,-1:nres))
20346       allocate(gg_tube_sc(3,-1:nres))
20347       allocate(gg_tube(3,-1:nres))
20348       allocate(gradafm(3,-1:nres))
20349       allocate(gradb_nucl(3,-1:nres))
20350       allocate(gradbx_nucl(3,-1:nres))
20351       allocate(gvdwpsb1(3,-1:nres))
20352       allocate(gelpp(3,-1:nres))
20353       allocate(gvdwpsb(3,-1:nres))
20354       allocate(gelsbc(3,-1:nres))
20355       allocate(gelsbx(3,-1:nres))
20356       allocate(gvdwsbx(3,-1:nres))
20357       allocate(gvdwsbc(3,-1:nres))
20358       allocate(gsbloc(3,-1:nres))
20359       allocate(gsblocx(3,-1:nres))
20360       allocate(gradcorr_nucl(3,-1:nres))
20361       allocate(gradxorr_nucl(3,-1:nres))
20362       allocate(gradcorr3_nucl(3,-1:nres))
20363       allocate(gradxorr3_nucl(3,-1:nres))
20364       allocate(gvdwpp_nucl(3,-1:nres))
20365       allocate(gradpepcat(3,-1:nres))
20366       allocate(gradpepcatx(3,-1:nres))
20367       allocate(gradcatcat(3,-1:nres))
20368       allocate(gradnuclcat(3,-1:nres))
20369       allocate(gradnuclcatx(3,-1:nres))
20370 !(3,maxres)
20371       allocate(grad_shield_side(3,maxcontsshi,-1:nres))
20372       allocate(grad_shield_loc(3,maxcontsshi,-1:nres))
20373 ! grad for shielding surroing
20374       allocate(gloc(0:maxvar,0:2))
20375       allocate(gloc_x(0:maxvar,2))
20376 !(maxvar,2)
20377       allocate(gel_loc(3,-1:nres))
20378       allocate(gel_loc_long(3,-1:nres))
20379       allocate(gcorr3_turn(3,-1:nres))
20380       allocate(gcorr4_turn(3,-1:nres))
20381       allocate(gcorr6_turn(3,-1:nres))
20382       allocate(gradb(3,-1:nres))
20383       allocate(gradbx(3,-1:nres))
20384 !(3,maxres)
20385       allocate(gel_loc_loc(maxvar))
20386       allocate(gel_loc_turn3(maxvar))
20387       allocate(gel_loc_turn4(maxvar))
20388       allocate(gel_loc_turn6(maxvar))
20389       allocate(gcorr_loc(maxvar))
20390       allocate(g_corr5_loc(maxvar))
20391       allocate(g_corr6_loc(maxvar))
20392 !(maxvar)
20393       allocate(gsccorc(3,-1:nres))
20394       allocate(gsccorx(3,-1:nres))
20395 !(3,maxres)
20396       allocate(gsccor_loc(-1:nres))
20397 !(maxres)
20398       allocate(gvdwx_scbase(3,-1:nres))
20399       allocate(gvdwc_scbase(3,-1:nres))
20400       allocate(gvdwx_pepbase(3,-1:nres))
20401       allocate(gvdwc_pepbase(3,-1:nres))
20402       allocate(gvdwx_scpho(3,-1:nres))
20403       allocate(gvdwc_scpho(3,-1:nres))
20404       allocate(gvdwc_peppho(3,-1:nres))
20405
20406       allocate(dtheta(3,2,-1:nres))
20407 !(3,2,maxres)
20408       allocate(gscloc(3,-1:nres))
20409       allocate(gsclocx(3,-1:nres))
20410 !(3,maxres)
20411       allocate(dphi(3,3,-1:nres))
20412       allocate(dalpha(3,3,-1:nres))
20413       allocate(domega(3,3,-1:nres))
20414 !(3,3,maxres)
20415 !      common /deriv_scloc/
20416       allocate(dXX_C1tab(3,nres))
20417       allocate(dYY_C1tab(3,nres))
20418       allocate(dZZ_C1tab(3,nres))
20419       allocate(dXX_Ctab(3,nres))
20420       allocate(dYY_Ctab(3,nres))
20421       allocate(dZZ_Ctab(3,nres))
20422       allocate(dXX_XYZtab(3,nres))
20423       allocate(dYY_XYZtab(3,nres))
20424       allocate(dZZ_XYZtab(3,nres))
20425 !(3,maxres)
20426 !      common /mpgrad/
20427       allocate(jgrad_start(nres))
20428       allocate(jgrad_end(nres))
20429 !(maxres)
20430 !----------------------
20431
20432 !      common /indices/
20433       allocate(ibond_displ(0:nfgtasks-1))
20434       allocate(ibond_count(0:nfgtasks-1))
20435       allocate(ithet_displ(0:nfgtasks-1))
20436       allocate(ithet_count(0:nfgtasks-1))
20437       allocate(iphi_displ(0:nfgtasks-1))
20438       allocate(iphi_count(0:nfgtasks-1))
20439       allocate(iphi1_displ(0:nfgtasks-1))
20440       allocate(iphi1_count(0:nfgtasks-1))
20441       allocate(ivec_displ(0:nfgtasks-1))
20442       allocate(ivec_count(0:nfgtasks-1))
20443       allocate(iset_displ(0:nfgtasks-1))
20444       allocate(iset_count(0:nfgtasks-1))
20445       allocate(iint_count(0:nfgtasks-1))
20446       allocate(iint_displ(0:nfgtasks-1))
20447 !(0:max_fg_procs-1)
20448 !----------------------
20449 ! common.MD
20450 !      common /mdgrad/
20451       allocate(gcart(3,-1:nres))
20452       allocate(gxcart(3,-1:nres))
20453 !(3,0:MAXRES)
20454       allocate(gradcag(3,-1:nres))
20455       allocate(gradxag(3,-1:nres))
20456 !(3,MAXRES)
20457 !      common /back_constr/
20458 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
20459       allocate(dutheta(nres))
20460       allocate(dugamma(nres))
20461 !(maxres)
20462       allocate(duscdiff(3,nres))
20463       allocate(duscdiffx(3,nres))
20464 !(3,maxres)
20465 !el i io:read_fragments
20466 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
20467 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
20468 !      common /qmeas/
20469 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
20470 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
20471       allocate(mset(0:nprocs))  !(maxprocs/20)
20472       mset(:)=0
20473 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
20474 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
20475       allocate(dUdconst(3,0:nres))
20476       allocate(dUdxconst(3,0:nres))
20477       allocate(dqwol(3,0:nres))
20478       allocate(dxqwol(3,0:nres))
20479 !(3,0:MAXRES)
20480 !----------------------
20481 ! common.sbridge
20482 !      common /sbridge/ in io_common: read_bridge
20483 !el    allocate((:),allocatable :: iss      !(maxss)
20484 !      common /links/  in io_common: read_bridge
20485 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
20486 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
20487 !      common /dyn_ssbond/
20488 ! and side-chain vectors in theta or phi.
20489       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
20490 !(maxres,maxres)
20491 !      do i=1,nres
20492 !        do j=i+1,nres
20493       dyn_ssbond_ij(:,:)=1.0d300
20494 !        enddo
20495 !      enddo
20496
20497 !      if (nss.gt.0) then
20498       allocate(idssb(maxdim),jdssb(maxdim))
20499 !        allocate(newihpb(nss),newjhpb(nss))
20500 !(maxdim)
20501 !      endif
20502       allocate(ishield_list(-1:nres))
20503       allocate(shield_list(maxcontsshi,-1:nres))
20504       allocate(dyn_ss_mask(nres))
20505       allocate(fac_shield(-1:nres))
20506       allocate(enetube(nres*2))
20507       allocate(enecavtube(nres*2))
20508
20509 !(maxres)
20510       dyn_ss_mask(:)=.false.
20511 !----------------------
20512 ! common.sccor
20513 ! Parameters of the SCCOR term
20514 !      common/sccor/
20515 !el in io_conf: parmread
20516 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
20517 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
20518 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
20519 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
20520 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
20521 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
20522 !      allocate(vlor1sccor(maxterm_sccor,20,20))
20523 !      allocate(vlor2sccor(maxterm_sccor,20,20))
20524 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
20525 !----------------
20526       allocate(gloc_sc(3,0:2*nres,0:10))
20527 !(3,0:maxres2,10)maxres2=2*maxres
20528       allocate(dcostau(3,3,3,2*nres))
20529       allocate(dsintau(3,3,3,2*nres))
20530       allocate(dtauangle(3,3,3,2*nres))
20531       allocate(dcosomicron(3,3,3,2*nres))
20532       allocate(domicron(3,3,3,2*nres))
20533 !(3,3,3,maxres2)maxres2=2*maxres
20534 !----------------------
20535 ! common.var
20536 !      common /restr/
20537       allocate(varall(maxvar))
20538 !(maxvar)(maxvar=6*maxres)
20539       allocate(mask_theta(nres))
20540       allocate(mask_phi(nres))
20541       allocate(mask_side(nres))
20542 !(maxres)
20543 !----------------------
20544 ! common.vectors
20545 !      common /vectors/
20546       allocate(uy(3,nres))
20547       allocate(uz(3,nres))
20548 !(3,maxres)
20549       allocate(uygrad(3,3,2,nres))
20550       allocate(uzgrad(3,3,2,nres))
20551 !(3,3,2,maxres)
20552 ! allocateion of lists JPRDLA
20553       allocate(newcontlistppi(300*nres))
20554       allocate(newcontlistscpi(300*nres))
20555       allocate(newcontlisti(300*nres))
20556       allocate(newcontlistppj(300*nres))
20557       allocate(newcontlistscpj(300*nres))
20558       allocate(newcontlistj(300*nres))
20559
20560       return
20561       end subroutine alloc_ener_arrays
20562 !-----------------------------------------------------------------
20563       subroutine ebond_nucl(estr_nucl)
20564 !c
20565 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
20566 !c
20567
20568       real(kind=8),dimension(3) :: u,ud
20569       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
20570       real(kind=8) :: estr_nucl,diff
20571       integer :: iti,i,j,k,nbi
20572       estr_nucl=0.0d0
20573 !C      print *,"I enter ebond"
20574       if (energy_dec) &
20575       write (iout,*) "ibondp_start,ibondp_end",&
20576        ibondp_nucl_start,ibondp_nucl_end
20577       do i=ibondp_nucl_start,ibondp_nucl_end
20578       if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
20579        itype(i,2).eq.ntyp1_molec(2)) cycle
20580 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
20581 !          do j=1,3
20582 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
20583 !     &      *dc(j,i-1)/vbld(i)
20584 !          enddo
20585 !          if (energy_dec) write(iout,*)
20586 !     &       "estr1",i,vbld(i),distchainmax,
20587 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
20588
20589         diff = vbld(i)-vbldp0_nucl
20590         if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
20591         vbldp0_nucl,diff,AKP_nucl*diff*diff
20592         estr_nucl=estr_nucl+diff*diff
20593 !          print *,estr_nucl
20594         do j=1,3
20595           gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
20596         enddo
20597 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
20598       enddo
20599       estr_nucl=0.5d0*AKP_nucl*estr_nucl
20600 !      print *,"partial sum", estr_nucl,AKP_nucl
20601
20602       if (energy_dec) &
20603       write (iout,*) "ibondp_start,ibondp_end",&
20604        ibond_nucl_start,ibond_nucl_end
20605
20606       do i=ibond_nucl_start,ibond_nucl_end
20607 !C        print *, "I am stuck",i
20608       iti=itype(i,2)
20609       if (iti.eq.ntyp1_molec(2)) cycle
20610         nbi=nbondterm_nucl(iti)
20611 !C        print *,iti,nbi
20612         if (nbi.eq.1) then
20613           diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
20614
20615           if (energy_dec) &
20616          write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
20617          AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
20618           estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
20619 !            print *,estr_nucl
20620           do j=1,3
20621             gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
20622           enddo
20623         else
20624           do j=1,nbi
20625             diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
20626             ud(j)=aksc_nucl(j,iti)*diff
20627             u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
20628           enddo
20629           uprod=u(1)
20630           do j=2,nbi
20631             uprod=uprod*u(j)
20632           enddo
20633           usum=0.0d0
20634           usumsqder=0.0d0
20635           do j=1,nbi
20636             uprod1=1.0d0
20637             uprod2=1.0d0
20638             do k=1,nbi
20639             if (k.ne.j) then
20640               uprod1=uprod1*u(k)
20641               uprod2=uprod2*u(k)*u(k)
20642             endif
20643             enddo
20644             usum=usum+uprod1
20645             usumsqder=usumsqder+ud(j)*uprod2
20646           enddo
20647           estr_nucl=estr_nucl+uprod/usum
20648           do j=1,3
20649            gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
20650           enddo
20651       endif
20652       enddo
20653 !C      print *,"I am about to leave ebond"
20654       return
20655       end subroutine ebond_nucl
20656
20657 !-----------------------------------------------------------------------------
20658       subroutine ebend_nucl(etheta_nucl)
20659       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
20660       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
20661       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
20662       logical :: lprn=.false., lprn1=.false.
20663 !el local variables
20664       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
20665       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
20666       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
20667 ! local variables for constrains
20668       real(kind=8) :: difi,thetiii
20669        integer itheta
20670       etheta_nucl=0.0D0
20671 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
20672       do i=ithet_nucl_start,ithet_nucl_end
20673       if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
20674       (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
20675       (itype(i,2).eq.ntyp1_molec(2))) cycle
20676       dethetai=0.0d0
20677       dephii=0.0d0
20678       dephii1=0.0d0
20679       theti2=0.5d0*theta(i)
20680       ityp2=ithetyp_nucl(itype(i-1,2))
20681       do k=1,nntheterm_nucl
20682         coskt(k)=dcos(k*theti2)
20683         sinkt(k)=dsin(k*theti2)
20684       enddo
20685       if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
20686 #ifdef OSF
20687         phii=phi(i)
20688         if (phii.ne.phii) phii=150.0
20689 #else
20690         phii=phi(i)
20691 #endif
20692         ityp1=ithetyp_nucl(itype(i-2,2))
20693         do k=1,nsingle_nucl
20694           cosph1(k)=dcos(k*phii)
20695           sinph1(k)=dsin(k*phii)
20696         enddo
20697       else
20698         phii=0.0d0
20699         ityp1=nthetyp_nucl+1
20700         do k=1,nsingle_nucl
20701           cosph1(k)=0.0d0
20702           sinph1(k)=0.0d0
20703         enddo
20704       endif
20705
20706       if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
20707 #ifdef OSF
20708         phii1=phi(i+1)
20709         if (phii1.ne.phii1) phii1=150.0
20710         phii1=pinorm(phii1)
20711 #else
20712         phii1=phi(i+1)
20713 #endif
20714         ityp3=ithetyp_nucl(itype(i,2))
20715         do k=1,nsingle_nucl
20716           cosph2(k)=dcos(k*phii1)
20717           sinph2(k)=dsin(k*phii1)
20718         enddo
20719       else
20720         phii1=0.0d0
20721         ityp3=nthetyp_nucl+1
20722         do k=1,nsingle_nucl
20723           cosph2(k)=0.0d0
20724           sinph2(k)=0.0d0
20725         enddo
20726       endif
20727       ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
20728       do k=1,ndouble_nucl
20729         do l=1,k-1
20730           ccl=cosph1(l)*cosph2(k-l)
20731           ssl=sinph1(l)*sinph2(k-l)
20732           scl=sinph1(l)*cosph2(k-l)
20733           csl=cosph1(l)*sinph2(k-l)
20734           cosph1ph2(l,k)=ccl-ssl
20735           cosph1ph2(k,l)=ccl+ssl
20736           sinph1ph2(l,k)=scl+csl
20737           sinph1ph2(k,l)=scl-csl
20738         enddo
20739       enddo
20740       if (lprn) then
20741       write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
20742        " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
20743       write (iout,*) "coskt and sinkt",nntheterm_nucl
20744       do k=1,nntheterm_nucl
20745         write (iout,*) k,coskt(k),sinkt(k)
20746       enddo
20747       endif
20748       do k=1,ntheterm_nucl
20749         ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
20750         dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
20751          *coskt(k)
20752         if (lprn)&
20753        write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
20754         " ethetai",ethetai
20755       enddo
20756       if (lprn) then
20757       write (iout,*) "cosph and sinph"
20758       do k=1,nsingle_nucl
20759         write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
20760       enddo
20761       write (iout,*) "cosph1ph2 and sinph2ph2"
20762       do k=2,ndouble_nucl
20763         do l=1,k-1
20764           write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
20765             sinph1ph2(l,k),sinph1ph2(k,l)
20766         enddo
20767       enddo
20768       write(iout,*) "ethetai",ethetai
20769       endif
20770       do m=1,ntheterm2_nucl
20771         do k=1,nsingle_nucl
20772           aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
20773             +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
20774             +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
20775             +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
20776           ethetai=ethetai+sinkt(m)*aux
20777           dethetai=dethetai+0.5d0*m*aux*coskt(m)
20778           dephii=dephii+k*sinkt(m)*(&
20779              ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
20780              bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
20781           dephii1=dephii1+k*sinkt(m)*(&
20782              eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
20783              ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
20784           if (lprn) &
20785          write (iout,*) "m",m," k",k," bbthet",&
20786             bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
20787             ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
20788             ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
20789             eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20790         enddo
20791       enddo
20792       if (lprn) &
20793       write(iout,*) "ethetai",ethetai
20794       do m=1,ntheterm3_nucl
20795         do k=2,ndouble_nucl
20796           do l=1,k-1
20797             aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20798              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
20799              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20800              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
20801             ethetai=ethetai+sinkt(m)*aux
20802             dethetai=dethetai+0.5d0*m*coskt(m)*aux
20803             dephii=dephii+l*sinkt(m)*(&
20804             -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
20805              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20806              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20807              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20808             dephii1=dephii1+(k-l)*sinkt(m)*( &
20809             -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20810              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20811              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
20812              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20813             if (lprn) then
20814             write (iout,*) "m",m," k",k," l",l," ffthet", &
20815              ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
20816              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
20817              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
20818              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20819             write (iout,*) cosph1ph2(l,k)*sinkt(m), &
20820              cosph1ph2(k,l)*sinkt(m),&
20821              sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
20822             endif
20823           enddo
20824         enddo
20825       enddo
20826 10      continue
20827       if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
20828       i,theta(i)*rad2deg,phii*rad2deg, &
20829       phii1*rad2deg,ethetai
20830       etheta_nucl=etheta_nucl+ethetai
20831 !        print *,i,"partial sum",etheta_nucl
20832       if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
20833       if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
20834       gloc(nphi+i-2,icg)=wang_nucl*dethetai
20835       enddo
20836       return
20837       end subroutine ebend_nucl
20838 !----------------------------------------------------
20839       subroutine etor_nucl(etors_nucl)
20840 !      implicit real*8 (a-h,o-z)
20841 !      include 'DIMENSIONS'
20842 !      include 'COMMON.VAR'
20843 !      include 'COMMON.GEO'
20844 !      include 'COMMON.LOCAL'
20845 !      include 'COMMON.TORSION'
20846 !      include 'COMMON.INTERACT'
20847 !      include 'COMMON.DERIV'
20848 !      include 'COMMON.CHAIN'
20849 !      include 'COMMON.NAMES'
20850 !      include 'COMMON.IOUNITS'
20851 !      include 'COMMON.FFIELD'
20852 !      include 'COMMON.TORCNSTR'
20853 !      include 'COMMON.CONTROL'
20854       real(kind=8) :: etors_nucl,edihcnstr
20855       logical :: lprn
20856 !el local variables
20857       integer :: i,j,iblock,itori,itori1
20858       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
20859                vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
20860 ! Set lprn=.true. for debugging
20861       lprn=.false.
20862 !     lprn=.true.
20863       etors_nucl=0.0D0
20864 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
20865       do i=iphi_nucl_start,iphi_nucl_end
20866       if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
20867            .or. itype(i-3,2).eq.ntyp1_molec(2) &
20868            .or. itype(i,2).eq.ntyp1_molec(2)) cycle
20869       etors_ii=0.0D0
20870       itori=itortyp_nucl(itype(i-2,2))
20871       itori1=itortyp_nucl(itype(i-1,2))
20872       phii=phi(i)
20873 !         print *,i,itori,itori1
20874       gloci=0.0D0
20875 !C Regular cosine and sine terms
20876       do j=1,nterm_nucl(itori,itori1)
20877         v1ij=v1_nucl(j,itori,itori1)
20878         v2ij=v2_nucl(j,itori,itori1)
20879         cosphi=dcos(j*phii)
20880         sinphi=dsin(j*phii)
20881         etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
20882         if (energy_dec) etors_ii=etors_ii+&
20883                  v1ij*cosphi+v2ij*sinphi
20884         gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
20885       enddo
20886 !C Lorentz terms
20887 !C                         v1
20888 !C  E = SUM ----------------------------------- - v1
20889 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
20890 !C
20891       cosphi=dcos(0.5d0*phii)
20892       sinphi=dsin(0.5d0*phii)
20893       do j=1,nlor_nucl(itori,itori1)
20894         vl1ij=vlor1_nucl(j,itori,itori1)
20895         vl2ij=vlor2_nucl(j,itori,itori1)
20896         vl3ij=vlor3_nucl(j,itori,itori1)
20897         pom=vl2ij*cosphi+vl3ij*sinphi
20898         pom1=1.0d0/(pom*pom+1.0d0)
20899         etors_nucl=etors_nucl+vl1ij*pom1
20900         if (energy_dec) etors_ii=etors_ii+ &
20901                  vl1ij*pom1
20902         pom=-pom*pom1*pom1
20903         gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
20904       enddo
20905 !C Subtract the constant term
20906       etors_nucl=etors_nucl-v0_nucl(itori,itori1)
20907         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
20908             'etor',i,etors_ii-v0_nucl(itori,itori1)
20909       if (lprn) &
20910        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
20911        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
20912        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
20913       gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
20914 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
20915       enddo
20916       return
20917       end subroutine etor_nucl
20918 !------------------------------------------------------------
20919       subroutine epp_nucl_sub(evdw1,ees)
20920 !C
20921 !C This subroutine calculates the average interaction energy and its gradient
20922 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
20923 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
20924 !C The potential depends both on the distance of peptide-group centers and on
20925 !C the orientation of the CA-CA virtual bonds.
20926 !C
20927       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
20928       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbbi,sslipi,ssgradlipi, &
20929                       sslipj,ssgradlipj,faclipij2
20930       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
20931              dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
20932              dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
20933       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20934                 dist_temp, dist_init,sss_grad,fac,evdw1ij
20935       integer xshift,yshift,zshift
20936       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
20937       real(kind=8) :: ees,eesij
20938 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20939       real(kind=8) scal_el /0.5d0/
20940       t_eelecij=0.0d0
20941       ees=0.0D0
20942       evdw1=0.0D0
20943       ind=0
20944 !c
20945 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
20946 !c
20947 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
20948       do i=iatel_s_nucl,iatel_e_nucl
20949       if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20950       dxi=dc(1,i)
20951       dyi=dc(2,i)
20952       dzi=dc(3,i)
20953       dx_normi=dc_norm(1,i)
20954       dy_normi=dc_norm(2,i)
20955       dz_normi=dc_norm(3,i)
20956       xmedi=c(1,i)+0.5d0*dxi
20957       ymedi=c(2,i)+0.5d0*dyi
20958       zmedi=c(3,i)+0.5d0*dzi
20959         call to_box(xmedi,ymedi,zmedi)
20960         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
20961
20962       do j=ielstart_nucl(i),ielend_nucl(i)
20963         if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
20964         ind=ind+1
20965         dxj=dc(1,j)
20966         dyj=dc(2,j)
20967         dzj=dc(3,j)
20968 !          xj=c(1,j)+0.5D0*dxj-xmedi
20969 !          yj=c(2,j)+0.5D0*dyj-ymedi
20970 !          zj=c(3,j)+0.5D0*dzj-zmedi
20971         xj=c(1,j)+0.5D0*dxj
20972         yj=c(2,j)+0.5D0*dyj
20973         zj=c(3,j)+0.5D0*dzj
20974      call to_box(xj,yj,zj)
20975      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
20976       faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
20977       xj=boxshift(xj-xmedi,boxxsize)
20978       yj=boxshift(yj-ymedi,boxysize)
20979       zj=boxshift(zj-zmedi,boxzsize)
20980         rij=xj*xj+yj*yj+zj*zj
20981 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
20982         fac=(r0pp**2/rij)**3
20983         ev1=epspp*fac*fac
20984         ev2=epspp*fac
20985         evdw1ij=ev1-2*ev2
20986         fac=(-ev1-evdw1ij)/rij
20987 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
20988         if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
20989         evdw1=evdw1+evdw1ij
20990 !C
20991 !C Calculate contributions to the Cartesian gradient.
20992 !C
20993         ggg(1)=fac*xj
20994         ggg(2)=fac*yj
20995         ggg(3)=fac*zj
20996         do k=1,3
20997           gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
20998           gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
20999         enddo
21000 !c phoshate-phosphate electrostatic interactions
21001         rij=dsqrt(rij)
21002         fac=1.0d0/rij
21003         eesij=dexp(-BEES*rij)*fac
21004 !          write (2,*)"fac",fac," eesijpp",eesij
21005         if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
21006         ees=ees+eesij
21007 !c          fac=-eesij*fac
21008         fac=-(fac+BEES)*eesij*fac
21009         ggg(1)=fac*xj
21010         ggg(2)=fac*yj
21011         ggg(3)=fac*zj
21012 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
21013 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
21014 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
21015         do k=1,3
21016           gelpp(k,i)=gelpp(k,i)-ggg(k)
21017           gelpp(k,j)=gelpp(k,j)+ggg(k)
21018         enddo
21019       enddo ! j
21020       enddo   ! i
21021 !c      ees=332.0d0*ees
21022       ees=AEES*ees
21023       do i=nnt,nct
21024 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21025       do k=1,3
21026         gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
21027 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
21028         gelpp(k,i)=AEES*gelpp(k,i)
21029       enddo
21030 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21031       enddo
21032 !c      write (2,*) "total EES",ees
21033       return
21034       end subroutine epp_nucl_sub
21035 !---------------------------------------------------------------------
21036       subroutine epsb(evdwpsb,eelpsb)
21037 !      use comm_locel
21038 !C
21039 !C This subroutine calculates the excluded-volume interaction energy between
21040 !C peptide-group centers and side chains and its gradient in virtual-bond and
21041 !C side-chain vectors.
21042 !C
21043       real(kind=8),dimension(3):: ggg
21044       integer :: i,iint,j,k,iteli,itypj,subchap
21045       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
21046                e1,e2,evdwij,rij,evdwpsb,eelpsb
21047       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21048                 dist_temp, dist_init
21049       integer xshift,yshift,zshift
21050
21051 !cd    print '(a)','Enter ESCP'
21052 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
21053       eelpsb=0.0d0
21054       evdwpsb=0.0d0
21055 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
21056       do i=iatscp_s_nucl,iatscp_e_nucl
21057       if (itype(i,2).eq.ntyp1_molec(2) &
21058        .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21059       xi=0.5D0*(c(1,i)+c(1,i+1))
21060       yi=0.5D0*(c(2,i)+c(2,i+1))
21061       zi=0.5D0*(c(3,i)+c(3,i+1))
21062         call to_box(xi,yi,zi)
21063
21064       do iint=1,nscp_gr_nucl(i)
21065
21066       do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
21067         itypj=itype(j,2)
21068         if (itypj.eq.ntyp1_molec(2)) cycle
21069 !C Uncomment following three lines for SC-p interactions
21070 !c         xj=c(1,nres+j)-xi
21071 !c         yj=c(2,nres+j)-yi
21072 !c         zj=c(3,nres+j)-zi
21073 !C Uncomment following three lines for Ca-p interactions
21074 !          xj=c(1,j)-xi
21075 !          yj=c(2,j)-yi
21076 !          zj=c(3,j)-zi
21077         xj=c(1,j)
21078         yj=c(2,j)
21079         zj=c(3,j)
21080         call to_box(xj,yj,zj)
21081       xj=boxshift(xj-xi,boxxsize)
21082       yj=boxshift(yj-yi,boxysize)
21083       zj=boxshift(zj-zi,boxzsize)
21084
21085       dist_init=xj**2+yj**2+zj**2
21086
21087         rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21088         fac=rrij**expon2
21089         e1=fac*fac*aad_nucl(itypj)
21090         e2=fac*bad_nucl(itypj)
21091         if (iabs(j-i) .le. 2) then
21092           e1=scal14*e1
21093           e2=scal14*e2
21094         endif
21095         evdwij=e1+e2
21096         evdwpsb=evdwpsb+evdwij
21097         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
21098            'evdw2',i,j,evdwij,"tu4"
21099 !C
21100 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
21101 !C
21102         fac=-(evdwij+e1)*rrij
21103         ggg(1)=xj*fac
21104         ggg(2)=yj*fac
21105         ggg(3)=zj*fac
21106         do k=1,3
21107           gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
21108           gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
21109         enddo
21110       enddo
21111
21112       enddo ! iint
21113       enddo ! i
21114       do i=1,nct
21115       do j=1,3
21116         gvdwpsb(j,i)=expon*gvdwpsb(j,i)
21117         gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
21118       enddo
21119       enddo
21120       return
21121       end subroutine epsb
21122
21123 !------------------------------------------------------
21124       subroutine esb_gb(evdwsb,eelsb)
21125       use comm_locel
21126       use calc_data_nucl
21127       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
21128       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
21129       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
21130       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21131                 dist_temp, dist_init,aa,bb,faclip,sig0ij
21132       integer :: ii
21133       logical lprn
21134       evdw=0.0D0
21135       eelsb=0.0d0
21136       ecorr=0.0d0
21137       evdwsb=0.0D0
21138       lprn=.false.
21139       ind=0
21140 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
21141       do i=iatsc_s_nucl,iatsc_e_nucl
21142       num_conti=0
21143       num_conti2=0
21144       itypi=itype(i,2)
21145 !        PRINT *,"I=",i,itypi
21146       if (itypi.eq.ntyp1_molec(2)) cycle
21147       itypi1=itype(i+1,2)
21148       xi=c(1,nres+i)
21149       yi=c(2,nres+i)
21150       zi=c(3,nres+i)
21151       call to_box(xi,yi,zi)
21152       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
21153       dxi=dc_norm(1,nres+i)
21154       dyi=dc_norm(2,nres+i)
21155       dzi=dc_norm(3,nres+i)
21156       dsci_inv=vbld_inv(i+nres)
21157 !C
21158 !C Calculate SC interaction energy.
21159 !C
21160       do iint=1,nint_gr_nucl(i)
21161 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
21162         do j=istart_nucl(i,iint),iend_nucl(i,iint)
21163           ind=ind+1
21164 !            print *,"JESTEM"
21165           itypj=itype(j,2)
21166           if (itypj.eq.ntyp1_molec(2)) cycle
21167           dscj_inv=vbld_inv(j+nres)
21168           sig0ij=sigma_nucl(itypi,itypj)
21169           chi1=chi_nucl(itypi,itypj)
21170           chi2=chi_nucl(itypj,itypi)
21171           chi12=chi1*chi2
21172           chip1=chip_nucl(itypi,itypj)
21173           chip2=chip_nucl(itypj,itypi)
21174           chip12=chip1*chip2
21175 !            xj=c(1,nres+j)-xi
21176 !            yj=c(2,nres+j)-yi
21177 !            zj=c(3,nres+j)-zi
21178          xj=c(1,nres+j)
21179          yj=c(2,nres+j)
21180          zj=c(3,nres+j)
21181      call to_box(xj,yj,zj)
21182 !     call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
21183 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
21184 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
21185 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
21186 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
21187       xj=boxshift(xj-xi,boxxsize)
21188       yj=boxshift(yj-yi,boxysize)
21189       zj=boxshift(zj-zi,boxzsize)
21190
21191           dxj=dc_norm(1,nres+j)
21192           dyj=dc_norm(2,nres+j)
21193           dzj=dc_norm(3,nres+j)
21194           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21195           rij=dsqrt(rrij)
21196 !C Calculate angle-dependent terms of energy and contributions to their
21197 !C derivatives.
21198           erij(1)=xj*rij
21199           erij(2)=yj*rij
21200           erij(3)=zj*rij
21201           om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
21202           om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
21203           om12=dxi*dxj+dyi*dyj+dzi*dzj
21204           call sc_angular_nucl
21205           sigsq=1.0D0/sigsq
21206           sig=sig0ij*dsqrt(sigsq)
21207           rij_shift=1.0D0/rij-sig+sig0ij
21208 !            print *,rij_shift,"rij_shift"
21209 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
21210 !c     &       " rij_shift",rij_shift
21211           if (rij_shift.le.0.0D0) then
21212             evdw=1.0D20
21213             return
21214           endif
21215           sigder=-sig*sigsq
21216 !c---------------------------------------------------------------
21217           rij_shift=1.0D0/rij_shift
21218           fac=rij_shift**expon
21219           e1=fac*fac*aa_nucl(itypi,itypj)
21220           e2=fac*bb_nucl(itypi,itypj)
21221           evdwij=eps1*eps2rt*(e1+e2)
21222 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
21223 !c     &       " e1",e1," e2",e2," evdwij",evdwij
21224           eps2der=evdwij
21225           evdwij=evdwij*eps2rt
21226           evdwsb=evdwsb+evdwij
21227           if (lprn) then
21228           sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
21229           epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
21230           write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
21231            restyp(itypi,2),i,restyp(itypj,2),j, &
21232            epsi,sigm,chi1,chi2,chip1,chip2, &
21233            eps1,eps2rt**2,sig,sig0ij, &
21234            om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
21235           evdwij
21236           write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
21237           endif
21238
21239           if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
21240                        'evdw',i,j,evdwij,"tu3"
21241
21242
21243 !C Calculate gradient components.
21244           e1=e1*eps1*eps2rt**2
21245           fac=-expon*(e1+evdwij)*rij_shift
21246           sigder=fac*sigder
21247           fac=rij*fac
21248 !c            fac=0.0d0
21249 !C Calculate the radial part of the gradient
21250           gg(1)=xj*fac
21251           gg(2)=yj*fac
21252           gg(3)=zj*fac
21253 !C Calculate angular part of the gradient.
21254           call sc_grad_nucl
21255           call eelsbij(eelij,num_conti2)
21256           if (energy_dec .and. &
21257          (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
21258         write (istat,'(e14.5)') evdwij
21259           eelsb=eelsb+eelij
21260         enddo      ! j
21261       enddo        ! iint
21262       num_cont_hb(i)=num_conti2
21263       enddo          ! i
21264 !c      write (iout,*) "Number of loop steps in EGB:",ind
21265 !cccc      energy_dec=.false.
21266       return
21267       end subroutine esb_gb
21268 !-------------------------------------------------------------------------------
21269       subroutine eelsbij(eesij,num_conti2)
21270       use comm_locel
21271       use calc_data_nucl
21272       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
21273       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
21274       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21275                 dist_temp, dist_init,rlocshield,fracinbuf
21276       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
21277
21278 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21279       real(kind=8) scal_el /0.5d0/
21280       integer :: iteli,itelj,kkk,kkll,m,isubchap
21281       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
21282       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
21283       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
21284               r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
21285               el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
21286               ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
21287               a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
21288               ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
21289               ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
21290               ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
21291       ind=ind+1
21292       itypi=itype(i,2)
21293       itypj=itype(j,2)
21294 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
21295       ael6i=ael6_nucl(itypi,itypj)
21296       ael3i=ael3_nucl(itypi,itypj)
21297       ael63i=ael63_nucl(itypi,itypj)
21298       ael32i=ael32_nucl(itypi,itypj)
21299 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
21300 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
21301       dxj=dc(1,j+nres)
21302       dyj=dc(2,j+nres)
21303       dzj=dc(3,j+nres)
21304       dx_normi=dc_norm(1,i+nres)
21305       dy_normi=dc_norm(2,i+nres)
21306       dz_normi=dc_norm(3,i+nres)
21307       dx_normj=dc_norm(1,j+nres)
21308       dy_normj=dc_norm(2,j+nres)
21309       dz_normj=dc_norm(3,j+nres)
21310 !c      xj=c(1,j)+0.5D0*dxj-xmedi
21311 !c      yj=c(2,j)+0.5D0*dyj-ymedi
21312 !c      zj=c(3,j)+0.5D0*dzj-zmedi
21313       if (ipot_nucl.ne.2) then
21314       cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
21315       cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
21316       cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
21317       else
21318       cosa=om12
21319       cosb=om1
21320       cosg=om2
21321       endif
21322       r3ij=rij*rrij
21323       r6ij=r3ij*r3ij
21324       fac=cosa-3.0D0*cosb*cosg
21325       facfac=fac*fac
21326       fac1=3.0d0*(cosb*cosb+cosg*cosg)
21327       fac3=ael6i*r6ij
21328       fac4=ael3i*r3ij
21329       fac5=ael63i*r6ij
21330       fac6=ael32i*r6ij
21331 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
21332 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
21333       el1=fac3*(4.0D0+facfac-fac1)
21334       el2=fac4*fac
21335       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
21336       el4=fac6*facfac
21337       eesij=el1+el2+el3+el4
21338 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
21339       ees0ij=4.0D0+facfac-fac1
21340
21341       if (energy_dec) then
21342         if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
21343         write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
21344          sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
21345          restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
21346          (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
21347         write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
21348       endif
21349
21350 !C
21351 !C Calculate contributions to the Cartesian gradient.
21352 !C
21353       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
21354       fac1=fac
21355 !c      erij(1)=xj*rmij
21356 !c      erij(2)=yj*rmij
21357 !c      erij(3)=zj*rmij
21358 !*
21359 !* Radial derivatives. First process both termini of the fragment (i,j)
21360 !*
21361       ggg(1)=facel*xj
21362       ggg(2)=facel*yj
21363       ggg(3)=facel*zj
21364       do k=1,3
21365       gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21366       gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21367       gelsbx(k,j)=gelsbx(k,j)+ggg(k)
21368       gelsbx(k,i)=gelsbx(k,i)-ggg(k)
21369       enddo
21370 !*
21371 !* Angular part
21372 !*
21373       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
21374       fac4=-3.0D0*fac4
21375       fac3=-6.0D0*fac3
21376       fac5= 6.0d0*fac5
21377       fac6=-6.0d0*fac6
21378       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
21379        fac6*fac1*cosg
21380       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
21381        fac6*fac1*cosb
21382       do k=1,3
21383       dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
21384       dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
21385       enddo
21386       do k=1,3
21387       ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
21388       enddo
21389       do k=1,3
21390       gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
21391            +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
21392            + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21393       gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
21394            +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21395            + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21396       gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21397       gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21398       enddo
21399 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
21400        IF ( j.gt.i+1 .and.&
21401         num_conti.le.maxcont) THEN
21402 !C
21403 !C Calculate the contact function. The ith column of the array JCONT will
21404 !C contain the numbers of atoms that make contacts with the atom I (of numbers
21405 !C greater than I). The arrays FACONT and GACONT will contain the values of
21406 !C the contact function and its derivative.
21407       r0ij=2.20D0*sigma_nucl(itypi,itypj)
21408 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
21409       call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
21410 !c        write (2,*) "fcont",fcont
21411       if (fcont.gt.0.0D0) then
21412         num_conti=num_conti+1
21413         num_conti2=num_conti2+1
21414
21415         if (num_conti.gt.maxconts) then
21416           write (iout,*) 'WARNING - max. # of contacts exceeded;',&
21417                     ' will skip next contacts for this conf.',maxconts
21418         else
21419           jcont_hb(num_conti,i)=j
21420 !c            write (iout,*) "num_conti",num_conti,
21421 !c     &        " jcont_hb",jcont_hb(num_conti,i)
21422 !C Calculate contact energies
21423           cosa4=4.0D0*cosa
21424           wij=cosa-3.0D0*cosb*cosg
21425           cosbg1=cosb+cosg
21426           cosbg2=cosb-cosg
21427           fac3=dsqrt(-ael6i)*r3ij
21428 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
21429           ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
21430           if (ees0tmp.gt.0) then
21431             ees0pij=dsqrt(ees0tmp)
21432           else
21433             ees0pij=0
21434           endif
21435           ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
21436           if (ees0tmp.gt.0) then
21437             ees0mij=dsqrt(ees0tmp)
21438           else
21439             ees0mij=0
21440           endif
21441           ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
21442           ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
21443 !c            write (iout,*) "i",i," j",j,
21444 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
21445           ees0pij1=fac3/ees0pij
21446           ees0mij1=fac3/ees0mij
21447           fac3p=-3.0D0*fac3*rrij
21448           ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
21449           ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
21450           ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
21451           ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
21452           ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
21453           ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
21454           ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
21455           ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
21456           ecosap=ecosa1+ecosa2
21457           ecosbp=ecosb1+ecosb2
21458           ecosgp=ecosg1+ecosg2
21459           ecosam=ecosa1-ecosa2
21460           ecosbm=ecosb1-ecosb2
21461           ecosgm=ecosg1-ecosg2
21462 !C End diagnostics
21463           facont_hb(num_conti,i)=fcont
21464           fprimcont=fprimcont/rij
21465           do k=1,3
21466             gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
21467             gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
21468           enddo
21469           gggp(1)=gggp(1)+ees0pijp*xj
21470           gggp(2)=gggp(2)+ees0pijp*yj
21471           gggp(3)=gggp(3)+ees0pijp*zj
21472           gggm(1)=gggm(1)+ees0mijp*xj
21473           gggm(2)=gggm(2)+ees0mijp*yj
21474           gggm(3)=gggm(3)+ees0mijp*zj
21475 !C Derivatives due to the contact function
21476           gacont_hbr(1,num_conti,i)=fprimcont*xj
21477           gacont_hbr(2,num_conti,i)=fprimcont*yj
21478           gacont_hbr(3,num_conti,i)=fprimcont*zj
21479           do k=1,3
21480 !c
21481 !c Gradient of the correlation terms
21482 !c
21483             gacontp_hb1(k,num_conti,i)= &
21484            (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21485           + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21486             gacontp_hb2(k,num_conti,i)= &
21487            (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
21488           + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21489             gacontp_hb3(k,num_conti,i)=gggp(k)
21490             gacontm_hb1(k,num_conti,i)= &
21491            (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21492           + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21493             gacontm_hb2(k,num_conti,i)= &
21494            (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21495           + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21496             gacontm_hb3(k,num_conti,i)=gggm(k)
21497           enddo
21498         endif
21499       endif
21500       ENDIF
21501       return
21502       end subroutine eelsbij
21503 !------------------------------------------------------------------
21504       subroutine sc_grad_nucl
21505       use comm_locel
21506       use calc_data_nucl
21507       real(kind=8),dimension(3) :: dcosom1,dcosom2
21508       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
21509       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
21510       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
21511       do k=1,3
21512       dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
21513       dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
21514       enddo
21515       do k=1,3
21516       gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
21517       enddo
21518       do k=1,3
21519       gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
21520              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
21521              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
21522       gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
21523              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
21524              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
21525       enddo
21526 !C
21527 !C Calculate the components of the gradient in DC and X
21528 !C
21529       do l=1,3
21530       gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
21531       gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
21532       enddo
21533       return
21534       end subroutine sc_grad_nucl
21535 !-----------------------------------------------------------------------
21536       subroutine esb(esbloc)
21537 !C Calculate the local energy of a side chain and its derivatives in the
21538 !C corresponding virtual-bond valence angles THETA and the spherical angles
21539 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
21540 !C added by Urszula Kozlowska. 07/11/2007
21541 !C
21542       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
21543       real(kind=8),dimension(9):: x
21544      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
21545       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
21546       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
21547       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
21548        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
21549        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
21550        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
21551        integer::it,nlobit,i,j,k
21552 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
21553       delta=0.02d0*pi
21554       esbloc=0.0D0
21555       do i=loc_start_nucl,loc_end_nucl
21556       if (itype(i,2).eq.ntyp1_molec(2)) cycle
21557       costtab(i+1) =dcos(theta(i+1))
21558       sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
21559       cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
21560       sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
21561       cosfac2=0.5d0/(1.0d0+costtab(i+1))
21562       cosfac=dsqrt(cosfac2)
21563       sinfac2=0.5d0/(1.0d0-costtab(i+1))
21564       sinfac=dsqrt(sinfac2)
21565       it=itype(i,2)
21566       if (it.eq.10) goto 1
21567
21568 !c
21569 !C  Compute the axes of tghe local cartesian coordinates system; store in
21570 !c   x_prime, y_prime and z_prime
21571 !c
21572       do j=1,3
21573         x_prime(j) = 0.00
21574         y_prime(j) = 0.00
21575         z_prime(j) = 0.00
21576       enddo
21577 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
21578 !C     &   dc_norm(3,i+nres)
21579       do j = 1,3
21580         x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
21581         y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
21582       enddo
21583       do j = 1,3
21584         z_prime(j) = -uz(j,i-1)
21585 !           z_prime(j)=0.0
21586       enddo
21587
21588       xx=0.0d0
21589       yy=0.0d0
21590       zz=0.0d0
21591       do j = 1,3
21592         xx = xx + x_prime(j)*dc_norm(j,i+nres)
21593         yy = yy + y_prime(j)*dc_norm(j,i+nres)
21594         zz = zz + z_prime(j)*dc_norm(j,i+nres)
21595       enddo
21596
21597       xxtab(i)=xx
21598       yytab(i)=yy
21599       zztab(i)=zz
21600        it=itype(i,2)
21601       do j = 1,9
21602         x(j) = sc_parmin_nucl(j,it)
21603       enddo
21604 #ifdef CHECK_COORD
21605 !Cc diagnostics - remove later
21606       xx1 = dcos(alph(2))
21607       yy1 = dsin(alph(2))*dcos(omeg(2))
21608       zz1 = -dsin(alph(2))*dsin(omeg(2))
21609       write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
21610        alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
21611        xx1,yy1,zz1
21612 !C,"  --- ", xx_w,yy_w,zz_w
21613 !c end diagnostics
21614 #endif
21615       sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21616       esbloc = esbloc + sumene
21617       sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
21618 !        print *,"enecomp",sumene,sumene2
21619 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
21620 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
21621 #ifdef DEBUG
21622       write (2,*) "x",(x(k),k=1,9)
21623 !C
21624 !C This section to check the numerical derivatives of the energy of ith side
21625 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
21626 !C #define DEBUG in the code to turn it on.
21627 !C
21628       write (2,*) "sumene               =",sumene
21629       aincr=1.0d-7
21630       xxsave=xx
21631       xx=xx+aincr
21632       write (2,*) xx,yy,zz
21633       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21634       de_dxx_num=(sumenep-sumene)/aincr
21635       xx=xxsave
21636       write (2,*) "xx+ sumene from enesc=",sumenep,sumene
21637       yysave=yy
21638       yy=yy+aincr
21639       write (2,*) xx,yy,zz
21640       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21641       de_dyy_num=(sumenep-sumene)/aincr
21642       yy=yysave
21643       write (2,*) "yy+ sumene from enesc=",sumenep,sumene
21644       zzsave=zz
21645       zz=zz+aincr
21646       write (2,*) xx,yy,zz
21647       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21648       de_dzz_num=(sumenep-sumene)/aincr
21649       zz=zzsave
21650       write (2,*) "zz+ sumene from enesc=",sumenep,sumene
21651       costsave=cost2tab(i+1)
21652       sintsave=sint2tab(i+1)
21653       cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
21654       sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
21655       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21656       de_dt_num=(sumenep-sumene)/aincr
21657       write (2,*) " t+ sumene from enesc=",sumenep,sumene
21658       cost2tab(i+1)=costsave
21659       sint2tab(i+1)=sintsave
21660 !C End of diagnostics section.
21661 #endif
21662 !C
21663 !C Compute the gradient of esc
21664 !C
21665       de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
21666       de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
21667       de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
21668       de_dtt=0.0d0
21669 #ifdef DEBUG
21670       write (2,*) "x",(x(k),k=1,9)
21671       write (2,*) "xx",xx," yy",yy," zz",zz
21672       write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
21673         " de_zz   ",de_zz," de_tt   ",de_tt
21674       write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
21675         " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
21676 #endif
21677 !C
21678        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
21679        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
21680        cosfac2xx=cosfac2*xx
21681        sinfac2yy=sinfac2*yy
21682        do k = 1,3
21683        dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
21684          vbld_inv(i+1)
21685        dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
21686          vbld_inv(i)
21687        pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
21688        pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
21689 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
21690 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
21691 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
21692 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
21693        dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
21694        dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
21695        dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
21696        dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
21697        dZZ_Ci1(k)=0.0d0
21698        dZZ_Ci(k)=0.0d0
21699        do j=1,3
21700          dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
21701          dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
21702        enddo
21703
21704        dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
21705        dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
21706        dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
21707 !c
21708        dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
21709        dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
21710        enddo
21711
21712        do k=1,3
21713        dXX_Ctab(k,i)=dXX_Ci(k)
21714        dXX_C1tab(k,i)=dXX_Ci1(k)
21715        dYY_Ctab(k,i)=dYY_Ci(k)
21716        dYY_C1tab(k,i)=dYY_Ci1(k)
21717        dZZ_Ctab(k,i)=dZZ_Ci(k)
21718        dZZ_C1tab(k,i)=dZZ_Ci1(k)
21719        dXX_XYZtab(k,i)=dXX_XYZ(k)
21720        dYY_XYZtab(k,i)=dYY_XYZ(k)
21721        dZZ_XYZtab(k,i)=dZZ_XYZ(k)
21722        enddo
21723        do k = 1,3
21724 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
21725 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
21726 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
21727 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
21728 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
21729 !c     &    dt_dci(k)
21730 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
21731 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
21732        gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
21733        +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
21734        gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
21735        +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
21736        gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
21737        +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
21738 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
21739        enddo
21740 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
21741 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
21742
21743 !C to check gradient call subroutine check_grad
21744
21745     1 continue
21746       enddo
21747       return
21748       end subroutine esb
21749 !=-------------------------------------------------------
21750       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
21751 !      implicit none
21752       real(kind=8),dimension(9):: x(9)
21753        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
21754       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
21755       integer i
21756 !c      write (2,*) "enesc"
21757 !c      write (2,*) "x",(x(i),i=1,9)
21758 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
21759       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
21760       + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
21761       + x(9)*yy*zz
21762       enesc_nucl=sumene
21763       return
21764       end function enesc_nucl
21765 !-----------------------------------------------------------------------------
21766       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
21767 #ifdef MPI
21768       include 'mpif.h'
21769       integer,parameter :: max_cont=2000
21770       integer,parameter:: max_dim=2*(8*3+6)
21771       integer, parameter :: msglen1=max_cont*max_dim
21772       integer,parameter :: msglen2=2*msglen1
21773       integer source,CorrelType,CorrelID,Error
21774       real(kind=8) :: buffer(max_cont,max_dim)
21775       integer status(MPI_STATUS_SIZE)
21776       integer :: ierror,nbytes
21777 #endif
21778       real(kind=8),dimension(3):: gx(3),gx1(3)
21779       real(kind=8) :: time00
21780       logical lprn,ldone
21781       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
21782       real(kind=8) ecorr,ecorr3
21783       integer :: n_corr,n_corr1,mm,msglen
21784 !C Set lprn=.true. for debugging
21785       lprn=.false.
21786       n_corr=0
21787       n_corr1=0
21788 #ifdef MPI
21789       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
21790
21791       if (nfgtasks.le.1) goto 30
21792       if (lprn) then
21793       write (iout,'(a)') 'Contact function values:'
21794       do i=nnt,nct-1
21795         write (iout,'(2i3,50(1x,i2,f5.2))')  &
21796        i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21797        j=1,num_cont_hb(i))
21798       enddo
21799       endif
21800 !C Caution! Following code assumes that electrostatic interactions concerning
21801 !C a given atom are split among at most two processors!
21802       CorrelType=477
21803       CorrelID=fg_rank+1
21804       ldone=.false.
21805       do i=1,max_cont
21806       do j=1,max_dim
21807         buffer(i,j)=0.0D0
21808       enddo
21809       enddo
21810       mm=mod(fg_rank,2)
21811 !c      write (*,*) 'MyRank',MyRank,' mm',mm
21812       if (mm) 20,20,10
21813    10 continue
21814 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
21815       if (fg_rank.gt.0) then
21816 !C Send correlation contributions to the preceding processor
21817       msglen=msglen1
21818       nn=num_cont_hb(iatel_s_nucl)
21819       call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
21820 !c        write (*,*) 'The BUFFER array:'
21821 !c        do i=1,nn
21822 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
21823 !c        enddo
21824       if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
21825         msglen=msglen2
21826         call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
21827 !C Clear the contacts of the atom passed to the neighboring processor
21828       nn=num_cont_hb(iatel_s_nucl+1)
21829 !c        do i=1,nn
21830 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
21831 !c        enddo
21832           num_cont_hb(iatel_s_nucl)=0
21833       endif
21834 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
21835 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
21836 !cd   & ' msglen=',msglen
21837 !c        write (*,*) 'Processor ',fg_rank,MyRank,
21838 !c     & ' is sending correlation contribution to processor',fg_rank-1,
21839 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21840       time00=MPI_Wtime()
21841       call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
21842        CorrelType,FG_COMM,IERROR)
21843       time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21844 !cd      write (iout,*) 'Processor ',fg_rank,
21845 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
21846 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
21847 !c        write (*,*) 'Processor ',fg_rank,
21848 !c     & ' has sent correlation contribution to processor',fg_rank-1,
21849 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
21850 !c        msglen=msglen1
21851       endif ! (fg_rank.gt.0)
21852       if (ldone) goto 30
21853       ldone=.true.
21854    20 continue
21855 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
21856       if (fg_rank.lt.nfgtasks-1) then
21857 !C Receive correlation contributions from the next processor
21858       msglen=msglen1
21859       if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
21860 !cd      write (iout,*) 'Processor',fg_rank,
21861 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
21862 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
21863 !c        write (*,*) 'Processor',fg_rank,
21864 !c     &' is receiving correlation contribution from processor',fg_rank+1,
21865 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21866       time00=MPI_Wtime()
21867       nbytes=-1
21868       do while (nbytes.le.0)
21869         call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21870         call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
21871       enddo
21872 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
21873       call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
21874        fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21875       time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21876 !c        write (*,*) 'Processor',fg_rank,
21877 !c     &' has received correlation contribution from processor',fg_rank+1,
21878 !c     & ' msglen=',msglen,' nbytes=',nbytes
21879 !c        write (*,*) 'The received BUFFER array:'
21880 !c        do i=1,max_cont
21881 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
21882 !c        enddo
21883       if (msglen.eq.msglen1) then
21884         call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
21885       else if (msglen.eq.msglen2)  then
21886         call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
21887         call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
21888       else
21889         write (iout,*) &
21890       'ERROR!!!! message length changed while processing correlations.'
21891         write (*,*) &
21892       'ERROR!!!! message length changed while processing correlations.'
21893         call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
21894       endif ! msglen.eq.msglen1
21895       endif ! fg_rank.lt.nfgtasks-1
21896       if (ldone) goto 30
21897       ldone=.true.
21898       goto 10
21899    30 continue
21900 #endif
21901       if (lprn) then
21902       write (iout,'(a)') 'Contact function values:'
21903       do i=nnt_molec(2),nct_molec(2)-1
21904         write (iout,'(2i3,50(1x,i2,f5.2))') &
21905        i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21906        j=1,num_cont_hb(i))
21907       enddo
21908       endif
21909       ecorr=0.0D0
21910       ecorr3=0.0d0
21911 !C Remove the loop below after debugging !!!
21912 !      do i=nnt_molec(2),nct_molec(2)
21913 !        do j=1,3
21914 !          gradcorr_nucl(j,i)=0.0D0
21915 !          gradxorr_nucl(j,i)=0.0D0
21916 !          gradcorr3_nucl(j,i)=0.0D0
21917 !          gradxorr3_nucl(j,i)=0.0D0
21918 !        enddo
21919 !      enddo
21920 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
21921 !C Calculate the local-electrostatic correlation terms
21922       do i=iatsc_s_nucl,iatsc_e_nucl
21923       i1=i+1
21924       num_conti=num_cont_hb(i)
21925       num_conti1=num_cont_hb(i+1)
21926 !        print *,i,num_conti,num_conti1
21927       do jj=1,num_conti
21928         j=jcont_hb(jj,i)
21929         do kk=1,num_conti1
21930           j1=jcont_hb(kk,i1)
21931 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
21932 !c     &         ' jj=',jj,' kk=',kk
21933           if (j1.eq.j+1 .or. j1.eq.j-1) then
21934 !C
21935 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
21936 !C The system gains extra energy.
21937 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
21938 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21939 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
21940 !C
21941             ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21942             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
21943              'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21944             n_corr=n_corr+1
21945           else if (j1.eq.j) then
21946 !C
21947 !C Contacts I-J and I-(J+1) occur simultaneously.
21948 !C The system loses extra energy.
21949 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
21950 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21951 !C Need to implement full formulas 32 from Liwo et al., 1998.
21952 !C
21953 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21954 !c     &         ' jj=',jj,' kk=',kk
21955             ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
21956           endif
21957         enddo ! kk
21958         do kk=1,num_conti
21959           j1=jcont_hb(kk,i)
21960 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21961 !c     &         ' jj=',jj,' kk=',kk
21962           if (j1.eq.j+1) then
21963 !C Contacts I-J and (I+1)-J occur simultaneously.
21964 !C The system loses extra energy.
21965             ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
21966           endif ! j1==j+1
21967         enddo ! kk
21968       enddo ! jj
21969       enddo ! i
21970       return
21971       end subroutine multibody_hb_nucl
21972 !-----------------------------------------------------------
21973       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21974 !      implicit real*8 (a-h,o-z)
21975 !      include 'DIMENSIONS'
21976 !      include 'COMMON.IOUNITS'
21977 !      include 'COMMON.DERIV'
21978 !      include 'COMMON.INTERACT'
21979 !      include 'COMMON.CONTACTS'
21980       real(kind=8),dimension(3) :: gx,gx1
21981       logical :: lprn
21982 !el local variables
21983       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21984       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21985                ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21986                coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21987                rlocshield
21988
21989       lprn=.false.
21990       eij=facont_hb(jj,i)
21991       ekl=facont_hb(kk,k)
21992       ees0pij=ees0p(jj,i)
21993       ees0pkl=ees0p(kk,k)
21994       ees0mij=ees0m(jj,i)
21995       ees0mkl=ees0m(kk,k)
21996       ekont=eij*ekl
21997       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21998 !      print *,"ehbcorr_nucl",ekont,ees
21999 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22000 !C Following 4 lines for diagnostics.
22001 !cd    ees0pkl=0.0D0
22002 !cd    ees0pij=1.0D0
22003 !cd    ees0mkl=0.0D0
22004 !cd    ees0mij=1.0D0
22005 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22006 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22007 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22008 !C Calculate the multi-body contribution to energy.
22009 !      ecorr_nucl=ecorr_nucl+ekont*ees
22010 !C Calculate multi-body contributions to the gradient.
22011       coeffpees0pij=coeffp*ees0pij
22012       coeffmees0mij=coeffm*ees0mij
22013       coeffpees0pkl=coeffp*ees0pkl
22014       coeffmees0mkl=coeffm*ees0mkl
22015       do ll=1,3
22016       gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
22017        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22018        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22019       gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
22020       -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
22021       coeffmees0mkl*gacontm_hb2(ll,jj,i))
22022       gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
22023       -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
22024       coeffmees0mij*gacontm_hb1(ll,kk,k))
22025       gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
22026       -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22027       coeffmees0mij*gacontm_hb2(ll,kk,k))
22028       gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22029         ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22030         coeffmees0mkl*gacontm_hb3(ll,jj,i))
22031       gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
22032       gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
22033       gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22034         ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22035         coeffmees0mij*gacontm_hb3(ll,kk,k))
22036       gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
22037       gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
22038       gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
22039       gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
22040       gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
22041       gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
22042       enddo
22043       ehbcorr_nucl=ekont*ees
22044       return
22045       end function ehbcorr_nucl
22046 !-------------------------------------------------------------------------
22047
22048      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22049 !      implicit real*8 (a-h,o-z)
22050 !      include 'DIMENSIONS'
22051 !      include 'COMMON.IOUNITS'
22052 !      include 'COMMON.DERIV'
22053 !      include 'COMMON.INTERACT'
22054 !      include 'COMMON.CONTACTS'
22055       real(kind=8),dimension(3) :: gx,gx1
22056       logical :: lprn
22057 !el local variables
22058       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22059       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22060                ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22061                coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22062                rlocshield
22063
22064       lprn=.false.
22065       eij=facont_hb(jj,i)
22066       ekl=facont_hb(kk,k)
22067       ees0pij=ees0p(jj,i)
22068       ees0pkl=ees0p(kk,k)
22069       ees0mij=ees0m(jj,i)
22070       ees0mkl=ees0m(kk,k)
22071       ekont=eij*ekl
22072       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22073 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22074 !C Following 4 lines for diagnostics.
22075 !cd    ees0pkl=0.0D0
22076 !cd    ees0pij=1.0D0
22077 !cd    ees0mkl=0.0D0
22078 !cd    ees0mij=1.0D0
22079 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22080 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22081 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22082 !C Calculate the multi-body contribution to energy.
22083 !      ecorr=ecorr+ekont*ees
22084 !C Calculate multi-body contributions to the gradient.
22085       coeffpees0pij=coeffp*ees0pij
22086       coeffmees0mij=coeffm*ees0mij
22087       coeffpees0pkl=coeffp*ees0pkl
22088       coeffmees0mkl=coeffm*ees0mkl
22089       do ll=1,3
22090       gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
22091        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22092        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22093       gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
22094       -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
22095       coeffmees0mkl*gacontm_hb2(ll,jj,i))
22096       gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
22097       -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
22098       coeffmees0mij*gacontm_hb1(ll,kk,k))
22099       gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
22100       -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22101       coeffmees0mij*gacontm_hb2(ll,kk,k))
22102       gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22103         ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22104         coeffmees0mkl*gacontm_hb3(ll,jj,i))
22105       gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
22106       gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
22107       gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22108         ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22109         coeffmees0mij*gacontm_hb3(ll,kk,k))
22110       gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
22111       gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
22112       gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
22113       gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
22114       gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
22115       gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
22116       enddo
22117       ehbcorr3_nucl=ekont*ees
22118       return
22119       end function ehbcorr3_nucl
22120 #ifdef MPI
22121       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
22122       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22123       real(kind=8):: buffer(dimen1,dimen2)
22124       num_kont=num_cont_hb(atom)
22125       do i=1,num_kont
22126       do k=1,8
22127         do j=1,3
22128           buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
22129         enddo ! j
22130       enddo ! k
22131       buffer(i,indx+25)=facont_hb(i,atom)
22132       buffer(i,indx+26)=ees0p(i,atom)
22133       buffer(i,indx+27)=ees0m(i,atom)
22134       buffer(i,indx+28)=d_cont(i,atom)
22135       buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
22136       enddo ! i
22137       buffer(1,indx+30)=dfloat(num_kont)
22138       return
22139       end subroutine pack_buffer
22140 !c------------------------------------------------------------------------------
22141       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
22142       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22143       real(kind=8):: buffer(dimen1,dimen2)
22144 !      double precision zapas
22145 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
22146 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
22147 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
22148 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
22149       num_kont=buffer(1,indx+30)
22150       num_kont_old=num_cont_hb(atom)
22151       num_cont_hb(atom)=num_kont+num_kont_old
22152       do i=1,num_kont
22153       ii=i+num_kont_old
22154       do k=1,8
22155         do j=1,3
22156           zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
22157         enddo ! j
22158       enddo ! k
22159       facont_hb(ii,atom)=buffer(i,indx+25)
22160       ees0p(ii,atom)=buffer(i,indx+26)
22161       ees0m(ii,atom)=buffer(i,indx+27)
22162       d_cont(i,atom)=buffer(i,indx+28)
22163       jcont_hb(ii,atom)=buffer(i,indx+29)
22164       enddo ! i
22165       return
22166       end subroutine unpack_buffer
22167 !c------------------------------------------------------------------------------
22168 #endif
22169       subroutine ecatcat(ecationcation)
22170       integer :: i,j,itmp,xshift,yshift,zshift,subchap,k,itypi,itypj
22171       real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22172       r7,r4,ecationcation,k0,rcal,aa,bb,sslipi,ssgradlipi,sslipj,ssgradlipj
22173       real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22174       dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
22175       real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22176       gg,r
22177
22178       ecationcation=0.0d0
22179       if (nres_molec(5).eq.0) return
22180       rcat0=3.472
22181       epscalc=0.05
22182       r06 = rcat0**6
22183       r012 = r06**2
22184 !        k0 = 332.0*(2.0*2.0)/80.0
22185       itmp=0
22186
22187       do i=1,4
22188       itmp=itmp+nres_molec(i)
22189       enddo
22190 !        write(iout,*) "itmp",itmp
22191       do i=itmp+1,itmp+nres_molec(5)-1
22192
22193       xi=c(1,i)
22194       yi=c(2,i)
22195       zi=c(3,i)
22196 !        write (iout,*) i,"TUTUT",c(1,i)
22197         itypi=itype(i,5)
22198       call to_box(xi,yi,zi)
22199       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
22200         do j=i+1,itmp+nres_molec(5)
22201         itypj=itype(j,5)
22202 !          print *,i,j,itypi,itypj
22203         k0 = 332.0*(ichargecat(itypi)*ichargecat(itypj))/80.0
22204 !           print *,i,j,'catcat'
22205          xj=c(1,j)
22206          yj=c(2,j)
22207          zj=c(3,j)
22208       call to_box(xj,yj,zj)
22209 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
22210 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22211 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22212 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22213 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22214       xj=boxshift(xj-xi,boxxsize)
22215       yj=boxshift(yj-yi,boxysize)
22216       zj=boxshift(zj-zi,boxzsize)
22217        rcal =xj**2+yj**2+zj**2
22218       ract=sqrt(rcal)
22219 !        rcat0=3.472
22220 !        epscalc=0.05
22221 !        r06 = rcat0**6
22222 !        r012 = r06**2
22223 !        k0 = 332*(2*2)/80
22224       Evan1cat=epscalc*(r012/(rcal**6))
22225       Evan2cat=epscalc*2*(r06/(rcal**3))
22226       Eeleccat=k0/ract
22227       r7 = rcal**7
22228       r4 = rcal**4
22229       r(1)=xj
22230       r(2)=yj
22231       r(3)=zj
22232       do k=1,3
22233         dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
22234         dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
22235         dEeleccat(k)=-k0*r(k)/ract**3
22236       enddo
22237       do k=1,3
22238         gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
22239         gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
22240         gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
22241       enddo
22242       if (energy_dec) write (iout,*) i,j,Evan1cat,Evan2cat,Eeleccat,&
22243        r012,rcal**6,ichargecat(itypi)*ichargecat(itypj)
22244 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
22245       ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
22246        enddo
22247        enddo
22248        return
22249        end subroutine ecatcat
22250 !---------------------------------------------------------------------------
22251 ! new for K+
22252       subroutine ecats_prot_amber(evdw)
22253 !      subroutine ecat_prot2(ecation_prot)
22254       use calc_data
22255       use comm_momo
22256
22257       logical :: lprn
22258 !el local variables
22259       integer :: iint,itypi1,subchap,isel,itmp
22260       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
22261       real(kind=8) :: evdw,aa,bb
22262       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22263                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
22264                 sslipi,sslipj,faclip,alpha_sco
22265       integer :: ii
22266       real(kind=8) :: fracinbuf
22267       real (kind=8) :: escpho
22268       real (kind=8),dimension(4):: ener
22269       real(kind=8) :: b1,b2,egb
22270       real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
22271        Lambf,&
22272        Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
22273        ecations_prot_amber,dFdOM2,dFdL,dFdOM12,&
22274        federmaus,&
22275        d1i,d1j
22276 !       real(kind=8),dimension(3,2)::erhead_tail
22277 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
22278       real(kind=8) ::  facd4, adler, Fgb, facd3
22279       integer troll,jj,istate
22280       real (kind=8) :: dcosom1(3),dcosom2(3)
22281       real(kind=8) ::locbox(3)
22282       locbox(1)=boxxsize
22283           locbox(2)=boxysize
22284       locbox(3)=boxzsize
22285
22286       evdw=0.0D0
22287       if (nres_molec(5).eq.0) return
22288       eps_out=80.0d0
22289 !      sss_ele_cut=1.0d0
22290
22291       itmp=0
22292       do i=1,4
22293       itmp=itmp+nres_molec(i)
22294       enddo
22295 !        go to 17
22296 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
22297       do i=ibond_start,ibond_end
22298
22299 !        print *,"I am in EVDW",i
22300       itypi=iabs(itype(i,1))
22301
22302 !        if (i.ne.47) cycle
22303       if ((itypi.eq.ntyp1).or.(itypi.eq.10)) cycle
22304       itypi1=iabs(itype(i+1,1))
22305       xi=c(1,nres+i)
22306       yi=c(2,nres+i)
22307       zi=c(3,nres+i)
22308       call to_box(xi,yi,zi)
22309       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
22310       dxi=dc_norm(1,nres+i)
22311       dyi=dc_norm(2,nres+i)
22312       dzi=dc_norm(3,nres+i)
22313       dsci_inv=vbld_inv(i+nres)
22314        do j=itmp+1,itmp+nres_molec(5)
22315
22316 ! Calculate SC interaction energy.
22317           itypj=iabs(itype(j,5))
22318           if ((itypj.eq.ntyp1)) cycle
22319            CALL elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
22320
22321           dscj_inv=0.0
22322          xj=c(1,j)
22323          yj=c(2,j)
22324          zj=c(3,j)
22325
22326       call to_box(xj,yj,zj)
22327 !      write(iout,*) "xi,yi,zi,xj,yj,zj", xi,yi,zi,xj,yj,zj
22328
22329 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
22330 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22331 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22332 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22333 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22334       xj=boxshift(xj-xi,boxxsize)
22335       yj=boxshift(yj-yi,boxysize)
22336       zj=boxshift(zj-zi,boxzsize)
22337 !      write(iout,*) "xj,yj,zj", xj,yj,zj,boxxsize
22338
22339 !          dxj = dc_norm( 1, nres+j )
22340 !          dyj = dc_norm( 2, nres+j )
22341 !          dzj = dc_norm( 3, nres+j )
22342
22343         itypi = itype(i,1)
22344         itypj = itype(j,5)
22345 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
22346 ! sampling performed with amber package
22347 !          alf1   = 0.0d0
22348 !          alf2   = 0.0d0
22349 !          alf12  = 0.0d0
22350 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
22351         chi1 = chi1cat(itypi,itypj)
22352         chis1 = chis1cat(itypi,itypj)
22353         chip1 = chipp1cat(itypi,itypj)
22354 !          chi1=0.0d0
22355 !          chis1=0.0d0
22356 !          chip1=0.0d0
22357         chi2=0.0
22358         chip2=0.0
22359         chis2=0.0
22360 !          chis2 = chis(itypj,itypi)
22361         chis12 = chis1 * chis2
22362         sig1 = sigmap1cat(itypi,itypj)
22363 !          sig2 = sigmap2(itypi,itypj)
22364 ! alpha factors from Fcav/Gcav
22365         b1cav = alphasurcat(1,itypi,itypj)
22366         b2cav = alphasurcat(2,itypi,itypj)
22367         b3cav = alphasurcat(3,itypi,itypj)
22368         b4cav = alphasurcat(4,itypi,itypj)
22369
22370 ! used to determine whether we want to do quadrupole calculations
22371        eps_in = epsintabcat(itypi,itypj)
22372        if (eps_in.eq.0.0) eps_in=1.0
22373
22374        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
22375 !       Rtail = 0.0d0
22376
22377        DO k = 1, 3
22378       ctail(k,1)=c(k,i+nres)
22379       ctail(k,2)=c(k,j)
22380        END DO
22381       call to_box(ctail(1,1),ctail(2,1),ctail(3,1))
22382       call to_box(ctail(1,2),ctail(2,2),ctail(3,2))
22383 !c! tail distances will be themselves usefull elswhere
22384 !c1 (in Gcav, for example)
22385        do k=1,3
22386        Rtail_distance(k) = boxshift(ctail(k,2) - ctail(k,1),locbox(k))
22387        enddo
22388        Rtail = dsqrt( &
22389         (Rtail_distance(1)*Rtail_distance(1)) &
22390       + (Rtail_distance(2)*Rtail_distance(2)) &
22391       + (Rtail_distance(3)*Rtail_distance(3)))
22392 ! tail location and distance calculations
22393 ! dhead1
22394        d1 = dheadcat(1, 1, itypi, itypj)
22395 !       d2 = dhead(2, 1, itypi, itypj)
22396        DO k = 1,3
22397 ! location of polar head is computed by taking hydrophobic centre
22398 ! and moving by a d1 * dc_norm vector
22399 ! see unres publications for very informative images
22400       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
22401       chead(k,2) = c(k, j)
22402       enddo
22403       call to_box(chead(1,1),chead(2,1),chead(3,1))
22404       call to_box(chead(1,2),chead(2,2),chead(3,2))
22405
22406 ! distance
22407 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22408 !         Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22409       do k=1,3
22410       Rhead_distance(k) = boxshift(chead(k,2) - chead(k,1),locbox(k))
22411        END DO
22412 ! pitagoras (root of sum of squares)
22413        Rhead = dsqrt( &
22414         (Rhead_distance(1)*Rhead_distance(1)) &
22415       + (Rhead_distance(2)*Rhead_distance(2)) &
22416       + (Rhead_distance(3)*Rhead_distance(3)))
22417 !-------------------------------------------------------------------
22418 ! zero everything that should be zero'ed
22419        evdwij = 0.0d0
22420        ECL = 0.0d0
22421        Elj = 0.0d0
22422        Equad = 0.0d0
22423        Epol = 0.0d0
22424        Fcav=0.0d0
22425        eheadtail = 0.0d0
22426        dGCLdOM1 = 0.0d0
22427        dGCLdOM2 = 0.0d0
22428        dGCLdOM12 = 0.0d0
22429        dPOLdOM1 = 0.0d0
22430        dPOLdOM2 = 0.0d0
22431         Fcav = 0.0d0
22432         Fisocav=0.0d0
22433         dFdR = 0.0d0
22434         dCAVdOM1  = 0.0d0
22435         dCAVdOM2  = 0.0d0
22436         dCAVdOM12 = 0.0d0
22437         dscj_inv = vbld_inv(j+nres)
22438 !          print *,i,j,dscj_inv,dsci_inv
22439 ! rij holds 1/(distance of Calpha atoms)
22440         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
22441         rij  = dsqrt(rrij)
22442         CALL sc_angular
22443 ! this should be in elgrad_init but om's are calculated by sc_angular
22444 ! which in turn is used by older potentials
22445 ! om = omega, sqom = om^2
22446         sqom1  = om1 * om1
22447         sqom2  = om2 * om2
22448         sqom12 = om12 * om12
22449
22450 ! now we calculate EGB - Gey-Berne
22451 ! It will be summed up in evdwij and saved in evdw
22452         sigsq     = 1.0D0  / sigsq
22453         sig       = sig0ij * dsqrt(sigsq)
22454 !          rij_shift = 1.0D0  / rij - sig + sig0ij
22455         rij_shift = Rtail - sig + sig0ij
22456         IF (rij_shift.le.0.0D0) THEN
22457          evdw = 1.0D20
22458          RETURN
22459         END IF
22460         sigder = -sig * sigsq
22461         rij_shift = 1.0D0 / rij_shift
22462         fac       = rij_shift**expon
22463         c1        = fac  * fac * aa_aq_cat(itypi,itypj)
22464 !          print *,"ADAM",aa_aq(itypi,itypj)
22465
22466 !          c1        = 0.0d0
22467         c2        = fac  * bb_aq_cat(itypi,itypj)
22468 !          c2        = 0.0d0
22469         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
22470         eps2der   = eps3rt * evdwij
22471         eps3der   = eps2rt * evdwij
22472 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
22473         evdwij    = eps2rt * eps3rt * evdwij
22474 !#ifdef TSCSC
22475 !          IF (bb_aq(itypi,itypj).gt.0) THEN
22476 !           evdw_p = evdw_p + evdwij
22477 !          ELSE
22478 !           evdw_m = evdw_m + evdwij
22479 !          END IF
22480 !#else
22481         evdw = evdw  &
22482             + evdwij
22483 !#endif
22484         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
22485         fac    = -expon * (c1 + evdwij) * rij_shift
22486         sigder = fac * sigder
22487 ! Calculate distance derivative
22488         gg(1) =  fac
22489         gg(2) =  fac
22490         gg(3) =  fac
22491
22492         fac = chis1 * sqom1 + chis2 * sqom2 &
22493         - 2.0d0 * chis12 * om1 * om2 * om12
22494         pom = 1.0d0 - chis1 * chis2 * sqom12
22495         Lambf = (1.0d0 - (fac / pom))
22496         Lambf = dsqrt(Lambf)
22497         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
22498         Chif = Rtail * sparrow
22499         ChiLambf = Chif * Lambf
22500         eagle = dsqrt(ChiLambf)
22501         bat = ChiLambf ** 11.0d0
22502         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
22503         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
22504         botsq = bot * bot
22505         Fcav = top / bot
22506
22507        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
22508        dbot = 12.0d0 * b4cav * bat * Lambf
22509        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
22510
22511         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
22512         dbot = 12.0d0 * b4cav * bat * Chif
22513         eagle = Lambf * pom
22514         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
22515         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
22516         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
22517             * (chis2 * om2 * om12 - om1) / (eagle * pom)
22518
22519         dFdL = ((dtop * bot - top * dbot) / botsq)
22520         dCAVdOM1  = dFdL * ( dFdOM1 )
22521         dCAVdOM2  = dFdL * ( dFdOM2 )
22522         dCAVdOM12 = dFdL * ( dFdOM12 )
22523
22524        DO k= 1, 3
22525       ertail(k) = Rtail_distance(k)/Rtail
22526        END DO
22527        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
22528        erdxj = scalar( ertail(1), dC_norm(1,j) )
22529        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
22530        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j+nres)
22531        DO k = 1, 3
22532       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
22533       gradpepcatx(k,i) = gradpepcatx(k,i) &
22534               - (( dFdR + gg(k) ) * pom)
22535       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
22536 !        gvdwx(k,j) = gvdwx(k,j)   &
22537 !                  + (( dFdR + gg(k) ) * pom)
22538       gradpepcat(k,i) = gradpepcat(k,i)  &
22539               - (( dFdR + gg(k) ) * ertail(k))
22540       gradpepcat(k,j) = gradpepcat(k,j) &
22541               + (( dFdR + gg(k) ) * ertail(k))
22542       gg(k) = 0.0d0
22543        ENDDO
22544 !c! Compute head-head and head-tail energies for each state
22545         isel = iabs(Qi) + 1 ! ion is always charged so  iabs(Qj)
22546         IF (isel.eq.0) THEN
22547 !c! No charges - do nothing
22548          eheadtail = 0.0d0
22549
22550         ELSE IF (isel.eq.1) THEN
22551 !c! Nonpolar-charge interactions
22552         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22553           Qi=Qi*2
22554           Qij=Qij*2
22555          endif
22556         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
22557           Qj=Qj*2
22558           Qij=Qij*2
22559          endif
22560
22561          CALL enq_cat(epol)
22562          eheadtail = epol
22563 !           eheadtail = 0.0d0
22564
22565         ELSE IF (isel.eq.3) THEN
22566 !c! Dipole-charge interactions
22567         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22568           Qi=Qi*2
22569           Qij=Qij*2
22570          endif
22571         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
22572           Qj=Qj*2
22573           Qij=Qij*2
22574          endif
22575 !         write(iout,*) "KURWA0",d1
22576
22577          CALL edq_cat(ecl, elj, epol)
22578         eheadtail = ECL + elj + epol
22579 !           eheadtail = 0.0d0
22580
22581         ELSE IF ((isel.eq.2)) THEN
22582
22583 !c! Same charge-charge interaction ( +/+ or -/- )
22584         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22585           Qi=Qi*2
22586           Qij=Qij*2
22587          endif
22588         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
22589           Qj=Qj*2
22590           Qij=Qij*2
22591          endif
22592
22593          CALL eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
22594          eheadtail = ECL + Egb + Epol + Fisocav + Elj
22595 !           eheadtail = 0.0d0
22596
22597 !          ELSE IF ((isel.eq.2.and.  &
22598 !               iabs(Qi).eq.1).and. &
22599 !               nstate(itypi,itypj).ne.1) THEN
22600 !c! Different charge-charge interaction ( +/- or -/+ )
22601 !          if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22602 !            Qi=Qi*2
22603 !            Qij=Qij*2
22604 !           endif
22605 !          if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
22606 !            Qj=Qj*2
22607 !            Qij=Qij*2
22608 !           endif
22609 !
22610 !           CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
22611        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
22612       evdw = evdw  + Fcav + eheadtail
22613
22614        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
22615       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
22616       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
22617       Equad,evdwij+Fcav+eheadtail,evdw
22618 !       evdw = evdw  + Fcav  + eheadtail
22619
22620 !        iF (nstate(itypi,itypj).eq.1) THEN
22621       CALL sc_grad_cat
22622 !       END IF
22623 !c!-------------------------------------------------------------------
22624 !c! NAPISY KONCOWE
22625        END DO   ! j
22626        END DO     ! i
22627 !c      write (iout,*) "Number of loop steps in EGB:",ind
22628 !c      energy_dec=.false.
22629 !              print *,"EVDW KURW",evdw,nres
22630 !!!        return
22631    17   continue
22632       do i=ibond_start,ibond_end
22633
22634 !        print *,"I am in EVDW",i
22635       itypi=10 ! the peptide group parameters are for glicine
22636
22637 !        if (i.ne.47) cycle
22638       if ((itype(i,1).eq.ntyp1).or.itype(i+1,1).eq.ntyp1) cycle
22639       itypi1=iabs(itype(i+1,1))
22640       xi=(c(1,i)+c(1,i+1))/2.0
22641       yi=(c(2,i)+c(2,i+1))/2.0
22642       zi=(c(3,i)+c(3,i+1))/2.0
22643         call to_box(xi,yi,zi)
22644       dxi=dc_norm(1,i)
22645       dyi=dc_norm(2,i)
22646       dzi=dc_norm(3,i)
22647       dsci_inv=vbld_inv(i+1)/2.0
22648        do j=itmp+1,itmp+nres_molec(5)
22649
22650 ! Calculate SC interaction energy.
22651           itypj=iabs(itype(j,5))
22652           if ((itypj.eq.ntyp1)) cycle
22653            CALL elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
22654
22655           dscj_inv=0.0
22656          xj=c(1,j)
22657          yj=c(2,j)
22658          zj=c(3,j)
22659         call to_box(xj,yj,zj)
22660       xj=boxshift(xj-xi,boxxsize)
22661       yj=boxshift(yj-yi,boxysize)
22662       zj=boxshift(zj-zi,boxzsize)
22663
22664         dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22665
22666         dxj = 0.0d0! dc_norm( 1, nres+j )
22667         dyj = 0.0d0!dc_norm( 2, nres+j )
22668         dzj = 0.0d0! dc_norm( 3, nres+j )
22669
22670         itypi = 10
22671         itypj = itype(j,5)
22672 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
22673 ! sampling performed with amber package
22674 !          alf1   = 0.0d0
22675 !          alf2   = 0.0d0
22676 !          alf12  = 0.0d0
22677 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
22678         chi1 = chi1cat(itypi,itypj)
22679         chis1 = chis1cat(itypi,itypj)
22680         chip1 = chipp1cat(itypi,itypj)
22681 !          chi1=0.0d0
22682 !          chis1=0.0d0
22683 !          chip1=0.0d0
22684         chi2=0.0
22685         chip2=0.0
22686         chis2=0.0
22687 !          chis2 = chis(itypj,itypi)
22688         chis12 = chis1 * chis2
22689         sig1 = sigmap1cat(itypi,itypj)
22690 !          sig2 = sigmap2(itypi,itypj)
22691 ! alpha factors from Fcav/Gcav
22692         b1cav = alphasurcat(1,itypi,itypj)
22693         b2cav = alphasurcat(2,itypi,itypj)
22694         b3cav = alphasurcat(3,itypi,itypj)
22695         b4cav = alphasurcat(4,itypi,itypj)
22696
22697 ! used to determine whether we want to do quadrupole calculations
22698        eps_in = epsintabcat(itypi,itypj)
22699        if (eps_in.eq.0.0) eps_in=1.0
22700
22701        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
22702 !       Rtail = 0.0d0
22703
22704        DO k = 1, 3
22705       ctail(k,1)=(c(k,i)+c(k,i+1))/2.0
22706       ctail(k,2)=c(k,j)
22707        END DO
22708       call to_box(ctail(1,1),ctail(2,1),ctail(3,1))
22709       call to_box(ctail(1,2),ctail(2,2),ctail(3,2))
22710 !c! tail distances will be themselves usefull elswhere
22711 !c1 (in Gcav, for example)
22712        do k=1,3
22713        Rtail_distance(k) = boxshift(ctail(k,2) - ctail(k,1),locbox(k))
22714        enddo
22715
22716 !c! tail distances will be themselves usefull elswhere
22717 !c1 (in Gcav, for example)
22718        Rtail = dsqrt( &
22719         (Rtail_distance(1)*Rtail_distance(1)) &
22720       + (Rtail_distance(2)*Rtail_distance(2)) &
22721       + (Rtail_distance(3)*Rtail_distance(3)))
22722 ! tail location and distance calculations
22723 ! dhead1
22724        d1 = dheadcat(1, 1, itypi, itypj)
22725 !       print *,"d1",d1
22726 !       d1=0.0d0
22727 !       d2 = dhead(2, 1, itypi, itypj)
22728        DO k = 1,3
22729 ! location of polar head is computed by taking hydrophobic centre
22730 ! and moving by a d1 * dc_norm vector
22731 ! see unres publications for very informative images
22732       chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
22733       chead(k,2) = c(k, j)
22734        ENDDO
22735 ! distance
22736 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22737 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22738       call to_box(chead(1,1),chead(2,1),chead(3,1))
22739       call to_box(chead(1,2),chead(2,2),chead(3,2))
22740
22741 ! distance
22742 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22743 !         Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22744       do k=1,3
22745       Rhead_distance(k) = boxshift(chead(k,2) - chead(k,1),locbox(k))
22746        END DO
22747
22748 ! pitagoras (root of sum of squares)
22749        Rhead = dsqrt( &
22750         (Rhead_distance(1)*Rhead_distance(1)) &
22751       + (Rhead_distance(2)*Rhead_distance(2)) &
22752       + (Rhead_distance(3)*Rhead_distance(3)))
22753 !-------------------------------------------------------------------
22754 ! zero everything that should be zero'ed
22755        evdwij = 0.0d0
22756        ECL = 0.0d0
22757        Elj = 0.0d0
22758        Equad = 0.0d0
22759        Epol = 0.0d0
22760        Fcav=0.0d0
22761        eheadtail = 0.0d0
22762        dGCLdOM1 = 0.0d0
22763        dGCLdOM2 = 0.0d0
22764        dGCLdOM12 = 0.0d0
22765        dPOLdOM1 = 0.0d0
22766        dPOLdOM2 = 0.0d0
22767         Fcav = 0.0d0
22768         dFdR = 0.0d0
22769         dCAVdOM1  = 0.0d0
22770         dCAVdOM2  = 0.0d0
22771         dCAVdOM12 = 0.0d0
22772         dscj_inv = vbld_inv(j+nres)
22773 !          print *,i,j,dscj_inv,dsci_inv
22774 ! rij holds 1/(distance of Calpha atoms)
22775         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
22776         rij  = dsqrt(rrij)
22777         CALL sc_angular
22778 ! this should be in elgrad_init but om's are calculated by sc_angular
22779 ! which in turn is used by older potentials
22780 ! om = omega, sqom = om^2
22781         sqom1  = om1 * om1
22782         sqom2  = om2 * om2
22783         sqom12 = om12 * om12
22784
22785 ! now we calculate EGB - Gey-Berne
22786 ! It will be summed up in evdwij and saved in evdw
22787         sigsq     = 1.0D0  / sigsq
22788         sig       = sig0ij * dsqrt(sigsq)
22789 !          rij_shift = 1.0D0  / rij - sig + sig0ij
22790         rij_shift = Rtail - sig + sig0ij
22791         IF (rij_shift.le.0.0D0) THEN
22792          evdw = 1.0D20
22793          RETURN
22794         END IF
22795         sigder = -sig * sigsq
22796         rij_shift = 1.0D0 / rij_shift
22797         fac       = rij_shift**expon
22798         c1        = fac  * fac * aa_aq_cat(itypi,itypj)
22799 !          print *,"ADAM",aa_aq(itypi,itypj)
22800
22801 !          c1        = 0.0d0
22802         c2        = fac  * bb_aq_cat(itypi,itypj)
22803 !          c2        = 0.0d0
22804         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
22805         eps2der   = eps3rt * evdwij
22806         eps3der   = eps2rt * evdwij
22807 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
22808         evdwij    = eps2rt * eps3rt * evdwij
22809 !#ifdef TSCSC
22810 !          IF (bb_aq(itypi,itypj).gt.0) THEN
22811 !           evdw_p = evdw_p + evdwij
22812 !          ELSE
22813 !           evdw_m = evdw_m + evdwij
22814 !          END IF
22815 !#else
22816         evdw = evdw  &
22817             + evdwij
22818 !#endif
22819         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
22820         fac    = -expon * (c1 + evdwij) * rij_shift
22821         sigder = fac * sigder
22822 ! Calculate distance derivative
22823         gg(1) =  fac
22824         gg(2) =  fac
22825         gg(3) =  fac
22826
22827         fac = chis1 * sqom1 + chis2 * sqom2 &
22828         - 2.0d0 * chis12 * om1 * om2 * om12
22829
22830         pom = 1.0d0 - chis1 * chis2 * sqom12
22831 !          print *,"TUT2",fac,chis1,sqom1,pom
22832         Lambf = (1.0d0 - (fac / pom))
22833         Lambf = dsqrt(Lambf)
22834         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
22835         Chif = Rtail * sparrow
22836         ChiLambf = Chif * Lambf
22837         eagle = dsqrt(ChiLambf)
22838         bat = ChiLambf ** 11.0d0
22839         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
22840         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
22841         botsq = bot * bot
22842         Fcav = top / bot
22843
22844        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
22845        dbot = 12.0d0 * b4cav * bat * Lambf
22846        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
22847
22848         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
22849         dbot = 12.0d0 * b4cav * bat * Chif
22850         eagle = Lambf * pom
22851         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
22852         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
22853         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
22854             * (chis2 * om2 * om12 - om1) / (eagle * pom)
22855
22856         dFdL = ((dtop * bot - top * dbot) / botsq)
22857         dCAVdOM1  = dFdL * ( dFdOM1 )
22858         dCAVdOM2  = dFdL * ( dFdOM2 )
22859         dCAVdOM12 = dFdL * ( dFdOM12 )
22860
22861        DO k= 1, 3
22862       ertail(k) = Rtail_distance(k)/Rtail
22863        END DO
22864        erdxi = scalar( ertail(1), dC_norm(1,i) )
22865        erdxj = scalar( ertail(1), dC_norm(1,j) )
22866        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i)
22867        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j+nres)
22868        DO k = 1, 3
22869       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i))
22870 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
22871 !                  - (( dFdR + gg(k) ) * pom)
22872       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
22873 !        gvdwx(k,j) = gvdwx(k,j)   &
22874 !                  + (( dFdR + gg(k) ) * pom)
22875       gradpepcat(k,i) = gradpepcat(k,i)  &
22876               - (( dFdR + gg(k) ) * ertail(k))/2.0d0
22877       gradpepcat(k,i+1) = gradpepcat(k,i+1)  &
22878               - (( dFdR + gg(k) ) * ertail(k))/2.0d0
22879
22880       gradpepcat(k,j) = gradpepcat(k,j) &
22881               + (( dFdR + gg(k) ) * ertail(k))
22882       gg(k) = 0.0d0
22883        ENDDO
22884 !c! Compute head-head and head-tail energies for each state
22885         isel = 3
22886 !c! Dipole-charge interactions
22887         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
22888           Qi=Qi*2
22889           Qij=Qij*2
22890          endif
22891         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
22892           Qj=Qj*2
22893           Qij=Qij*2
22894          endif
22895          CALL edq_cat_pep(ecl, elj, epol)
22896          eheadtail = ECL + elj + epol
22897 !          print *,"i,",i,eheadtail
22898 !           eheadtail = 0.0d0
22899
22900       evdw = evdw  + Fcav + eheadtail
22901
22902        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
22903       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
22904       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
22905       Equad,evdwij+Fcav+eheadtail,evdw
22906 !       evdw = evdw  + Fcav  + eheadtail
22907
22908 !        iF (nstate(itypi,itypj).eq.1) THEN
22909       CALL sc_grad_cat_pep
22910 !       END IF
22911 !c!-------------------------------------------------------------------
22912 !c! NAPISY KONCOWE
22913        END DO   ! j
22914        END DO     ! i
22915 !c      write (iout,*) "Number of loop steps in EGB:",ind
22916 !c      energy_dec=.false.
22917 !              print *,"EVDW KURW",evdw,nres
22918
22919
22920       return
22921       end subroutine ecats_prot_amber
22922
22923 !---------------------------------------------------------------------------
22924 ! old for Ca2+
22925        subroutine ecat_prot(ecation_prot)
22926 !      use calc_data
22927 !      use comm_momo
22928        integer i,j,k,subchap,itmp,inum
22929       real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22930       r7,r4,ecationcation
22931       real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22932       dist_init,dist_temp,ecation_prot,rcal,rocal,   &
22933       Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
22934       catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
22935       wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
22936       costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
22937       Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
22938       rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
22939       opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
22940       opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
22941       Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip,&
22942       ndiv,ndivi
22943       real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22944       gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
22945       dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
22946       tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
22947       v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
22948       dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
22949       dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
22950       dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
22951       dEvan1Cat
22952       real(kind=8),dimension(6) :: vcatprm
22953       ecation_prot=0.0d0
22954 ! first lets calculate interaction with peptide groups
22955       if (nres_molec(5).eq.0) return
22956       itmp=0
22957       do i=1,4
22958       itmp=itmp+nres_molec(i)
22959       enddo
22960 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
22961       do i=ibond_start,ibond_end
22962 !         cycle
22963        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
22964       xi=0.5d0*(c(1,i)+c(1,i+1))
22965       yi=0.5d0*(c(2,i)+c(2,i+1))
22966       zi=0.5d0*(c(3,i)+c(3,i+1))
22967         call to_box(xi,yi,zi)
22968
22969        do j=itmp+1,itmp+nres_molec(5)
22970 !           print *,"WTF",itmp,j,i
22971 ! all parameters were for Ca2+ to approximate single charge divide by two
22972        ndiv=1.0
22973        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
22974        wconst=78*ndiv
22975       wdip =1.092777950857032D2
22976       wdip=wdip/wconst
22977       wmodquad=-2.174122713004870D4
22978       wmodquad=wmodquad/wconst
22979       wquad1 = 3.901232068562804D1
22980       wquad1=wquad1/wconst
22981       wquad2 = 3
22982       wquad2=wquad2/wconst
22983       wvan1 = 0.1
22984       wvan2 = 6
22985 !        itmp=0
22986
22987          xj=c(1,j)
22988          yj=c(2,j)
22989          zj=c(3,j)
22990         call to_box(xj,yj,zj)
22991       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22992 !       enddo
22993 !       enddo
22994        rcpm = sqrt(xj**2+yj**2+zj**2)
22995        drcp_norm(1)=xj/rcpm
22996        drcp_norm(2)=yj/rcpm
22997        drcp_norm(3)=zj/rcpm
22998        dcmag=0.0
22999        do k=1,3
23000        dcmag=dcmag+dc(k,i)**2
23001        enddo
23002        dcmag=dsqrt(dcmag)
23003        do k=1,3
23004        myd_norm(k)=dc(k,i)/dcmag
23005        enddo
23006       costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
23007       drcp_norm(3)*myd_norm(3)
23008       rsecp = rcpm**2
23009       Ir = 1.0d0/rcpm
23010       Irsecp = 1.0d0/rsecp
23011       Irthrp = Irsecp/rcpm
23012       Irfourp = Irthrp/rcpm
23013       Irfiftp = Irfourp/rcpm
23014       Irsistp=Irfiftp/rcpm
23015       Irseven=Irsistp/rcpm
23016       Irtwelv=Irsistp*Irsistp
23017       Irthir=Irtwelv/rcpm
23018       sin2thet = (1-costhet*costhet)
23019       sinthet=sqrt(sin2thet)
23020       E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
23021            *sin2thet
23022       E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
23023            2*wvan2**6*Irsistp)
23024       ecation_prot = ecation_prot+E1+E2
23025 !        print *,"ecatprot",i,j,ecation_prot,rcpm
23026       dE1dr = -2*costhet*wdip*Irthrp-&
23027        (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
23028       dE2dr = 3*wquad1*wquad2*Irfourp-     &
23029         12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
23030       dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
23031       do k=1,3
23032         drdpep(k) = -drcp_norm(k)
23033         dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
23034         dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
23035         dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
23036         dEddci(k) = dEdcos*dcosddci(k)
23037       enddo
23038       do k=1,3
23039       gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
23040       gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
23041       gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
23042       enddo
23043        enddo ! j
23044        enddo ! i
23045 !------------------------------------------sidechains
23046 !        do i=1,nres_molec(1)
23047       do i=ibond_start,ibond_end
23048        if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
23049 !         cycle
23050 !        print *,i,ecation_prot
23051       xi=(c(1,i+nres))
23052       yi=(c(2,i+nres))
23053       zi=(c(3,i+nres))
23054                 call to_box(xi,yi,zi)
23055         do k=1,3
23056           cm1(k)=dc(k,i+nres)
23057         enddo
23058          cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
23059        do j=itmp+1,itmp+nres_molec(5)
23060        ndiv=1.0
23061        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23062
23063          xj=c(1,j)
23064          yj=c(2,j)
23065          zj=c(3,j)
23066         call to_box(xj,yj,zj)
23067       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23068 !       enddo
23069 !       enddo
23070 ! 15- Glu 16-Asp
23071        if((itype(i,1).eq.15.or.itype(i,1).eq.16).or.&
23072        ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.&
23073        (itype(i,1).eq.25))) then
23074           if(itype(i,1).eq.16) then
23075           inum=1
23076           else
23077           inum=2
23078           endif
23079           do k=1,6
23080           vcatprm(k)=catprm(k,inum)
23081           enddo
23082           dASGL=catprm(7,inum)
23083 !             do k=1,3
23084 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23085             vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23086             vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23087             vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23088
23089 !                valpha(k)=c(k,i)
23090 !                vcat(k)=c(k,j)
23091             if (subchap.eq.1) then
23092              vcat(1)=xj_temp
23093              vcat(2)=yj_temp
23094              vcat(3)=zj_temp
23095              else
23096             vcat(1)=xj_safe
23097             vcat(2)=yj_safe
23098             vcat(3)=zj_safe
23099              endif
23100             valpha(1)=xi-c(1,i+nres)+c(1,i)
23101             valpha(2)=yi-c(2,i+nres)+c(2,i)
23102             valpha(3)=zi-c(3,i+nres)+c(3,i)
23103
23104 !              enddo
23105       do k=1,3
23106         dx(k) = vcat(k)-vcm(k)
23107       enddo
23108       do k=1,3
23109         v1(k)=(vcm(k)-valpha(k))
23110         v2(k)=(vcat(k)-valpha(k))
23111       enddo
23112       v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23113       v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23114       v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23115
23116 !  The weights of the energy function calculated from
23117 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
23118         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23119           ndivi=0.5
23120         else
23121           ndivi=1.0
23122         endif
23123        ndiv=1.0
23124        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23125
23126       wh2o=78*ndivi*ndiv
23127       wc = vcatprm(1)
23128       wc=wc/wh2o
23129       wdip =vcatprm(2)
23130       wdip=wdip/wh2o
23131       wquad1 =vcatprm(3)
23132       wquad1=wquad1/wh2o
23133       wquad2 = vcatprm(4)
23134       wquad2=wquad2/wh2o
23135       wquad2p = 1.0d0-wquad2
23136       wvan1 = vcatprm(5)
23137       wvan2 =vcatprm(6)
23138       opt = dx(1)**2+dx(2)**2
23139       rsecp = opt+dx(3)**2
23140       rs = sqrt(rsecp)
23141       rthrp = rsecp*rs
23142       rfourp = rthrp*rs
23143       rsixp = rfourp*rsecp
23144       reight=rsixp*rsecp
23145       Ir = 1.0d0/rs
23146       Irsecp = 1.0d0/rsecp
23147       Irthrp = Irsecp/rs
23148       Irfourp = Irthrp/rs
23149       Irsixp = 1.0d0/rsixp
23150       Ireight=1.0d0/reight
23151       Irtw=Irsixp*Irsixp
23152       Irthir=Irtw/rs
23153       Irfourt=Irthir/rs
23154       opt1 = (4*rs*dx(3)*wdip)
23155       opt2 = 6*rsecp*wquad1*opt
23156       opt3 = wquad1*wquad2p*Irsixp
23157       opt4 = (wvan1*wvan2**12)
23158       opt5 = opt4*12*Irfourt
23159       opt6 = 2*wvan1*wvan2**6
23160       opt7 = 6*opt6*Ireight
23161       opt8 = wdip/v1m
23162       opt10 = wdip/v2m
23163       opt11 = (rsecp*v2m)**2
23164       opt12 = (rsecp*v1m)**2
23165       opt14 = (v1m*v2m*rsecp)**2
23166       opt15 = -wquad1/v2m**2
23167       opt16 = (rthrp*(v1m*v2m)**2)**2
23168       opt17 = (v1m**2*rthrp)**2
23169       opt18 = -wquad1/rthrp
23170       opt19 = (v1m**2*v2m**2)**2
23171       Ec = wc*Ir
23172       do k=1,3
23173         dEcCat(k) = -(dx(k)*wc)*Irthrp
23174         dEcCm(k)=(dx(k)*wc)*Irthrp
23175         dEcCalp(k)=0.0d0
23176       enddo
23177       Edip=opt8*(v1dpv2)/(rsecp*v2m)
23178       do k=1,3
23179         dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
23180                  *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23181         dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
23182                 *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23183         dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
23184                   *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
23185                   *v1dpv2)/opt14
23186       enddo
23187       Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23188       do k=1,3
23189         dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
23190                    (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
23191                    v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23192         dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
23193                   (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
23194                   v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23195         dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23196                   v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
23197                   v1dpv2**2)/opt19
23198       enddo
23199       Equad2=wquad1*wquad2p*Irthrp
23200       do k=1,3
23201         dEquad2Cat(k)=-3*dx(k)*rs*opt3
23202         dEquad2Cm(k)=3*dx(k)*rs*opt3
23203         dEquad2Calp(k)=0.0d0
23204       enddo
23205       Evan1=opt4*Irtw
23206       do k=1,3
23207         dEvan1Cat(k)=-dx(k)*opt5
23208         dEvan1Cm(k)=dx(k)*opt5
23209         dEvan1Calp(k)=0.0d0
23210       enddo
23211       Evan2=-opt6*Irsixp
23212       do k=1,3
23213         dEvan2Cat(k)=dx(k)*opt7
23214         dEvan2Cm(k)=-dx(k)*opt7
23215         dEvan2Calp(k)=0.0d0
23216       enddo
23217       ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
23218 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
23219
23220       do k=1,3
23221         dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
23222                    dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23223 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
23224         dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
23225                   dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23226         dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
23227                   +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23228       enddo
23229           dscmag = 0.0d0
23230           do k=1,3
23231             dscvec(k) = dc(k,i+nres)
23232             dscmag = dscmag+dscvec(k)*dscvec(k)
23233           enddo
23234           dscmag3 = dscmag
23235           dscmag = sqrt(dscmag)
23236           dscmag3 = dscmag3*dscmag
23237           constA = 1.0d0+dASGL/dscmag
23238           constB = 0.0d0
23239           do k=1,3
23240             constB = constB+dscvec(k)*dEtotalCm(k)
23241           enddo
23242           constB = constB*dASGL/dscmag3
23243           do k=1,3
23244             gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23245             gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23246              constA*dEtotalCm(k)-constB*dscvec(k)
23247 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
23248             gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23249             gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23250            enddo
23251       else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
23252          if(itype(i,1).eq.14) then
23253           inum=3
23254           else
23255           inum=4
23256           endif
23257           do k=1,6
23258           vcatprm(k)=catprm(k,inum)
23259           enddo
23260           dASGL=catprm(7,inum)
23261 !             do k=1,3
23262 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23263 !                valpha(k)=c(k,i)
23264 !                vcat(k)=c(k,j)
23265 !              enddo
23266             vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23267             vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23268             vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23269             if (subchap.eq.1) then
23270              vcat(1)=xj_temp
23271              vcat(2)=yj_temp
23272              vcat(3)=zj_temp
23273              else
23274             vcat(1)=xj_safe
23275             vcat(2)=yj_safe
23276             vcat(3)=zj_safe
23277             endif
23278             valpha(1)=xi-c(1,i+nres)+c(1,i)
23279             valpha(2)=yi-c(2,i+nres)+c(2,i)
23280             valpha(3)=zi-c(3,i+nres)+c(3,i)
23281
23282
23283       do k=1,3
23284         dx(k) = vcat(k)-vcm(k)
23285       enddo
23286       do k=1,3
23287         v1(k)=(vcm(k)-valpha(k))
23288         v2(k)=(vcat(k)-valpha(k))
23289       enddo
23290       v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23291       v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23292       v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23293 !  The weights of the energy function calculated from
23294 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
23295        ndiv=1.0
23296        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23297
23298       wh2o=78*ndiv
23299       wdip =vcatprm(2)
23300       wdip=wdip/wh2o
23301       wquad1 =vcatprm(3)
23302       wquad1=wquad1/wh2o
23303       wquad2 = vcatprm(4)
23304       wquad2=wquad2/wh2o
23305       wquad2p = 1-wquad2
23306       wvan1 = vcatprm(5)
23307       wvan2 =vcatprm(6)
23308       opt = dx(1)**2+dx(2)**2
23309       rsecp = opt+dx(3)**2
23310       rs = sqrt(rsecp)
23311       rthrp = rsecp*rs
23312       rfourp = rthrp*rs
23313       rsixp = rfourp*rsecp
23314       reight=rsixp*rsecp
23315       Ir = 1.0d0/rs
23316       Irsecp = 1/rsecp
23317       Irthrp = Irsecp/rs
23318       Irfourp = Irthrp/rs
23319       Irsixp = 1/rsixp
23320       Ireight=1/reight
23321       Irtw=Irsixp*Irsixp
23322       Irthir=Irtw/rs
23323       Irfourt=Irthir/rs
23324       opt1 = (4*rs*dx(3)*wdip)
23325       opt2 = 6*rsecp*wquad1*opt
23326       opt3 = wquad1*wquad2p*Irsixp
23327       opt4 = (wvan1*wvan2**12)
23328       opt5 = opt4*12*Irfourt
23329       opt6 = 2*wvan1*wvan2**6
23330       opt7 = 6*opt6*Ireight
23331       opt8 = wdip/v1m
23332       opt10 = wdip/v2m
23333       opt11 = (rsecp*v2m)**2
23334       opt12 = (rsecp*v1m)**2
23335       opt14 = (v1m*v2m*rsecp)**2
23336       opt15 = -wquad1/v2m**2
23337       opt16 = (rthrp*(v1m*v2m)**2)**2
23338       opt17 = (v1m**2*rthrp)**2
23339       opt18 = -wquad1/rthrp
23340       opt19 = (v1m**2*v2m**2)**2
23341       Edip=opt8*(v1dpv2)/(rsecp*v2m)
23342       do k=1,3
23343         dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
23344                  *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23345        dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
23346                 *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23347         dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
23348                   *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
23349                   *v1dpv2)/opt14
23350       enddo
23351       Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23352       do k=1,3
23353         dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
23354                    (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
23355                    v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23356         dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
23357                   (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
23358                    v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
23359         dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
23360                   v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
23361                   v1dpv2**2)/opt19
23362       enddo
23363       Equad2=wquad1*wquad2p*Irthrp
23364       do k=1,3
23365         dEquad2Cat(k)=-3*dx(k)*rs*opt3
23366         dEquad2Cm(k)=3*dx(k)*rs*opt3
23367         dEquad2Calp(k)=0.0d0
23368       enddo
23369       Evan1=opt4*Irtw
23370       do k=1,3
23371         dEvan1Cat(k)=-dx(k)*opt5
23372         dEvan1Cm(k)=dx(k)*opt5
23373         dEvan1Calp(k)=0.0d0
23374       enddo
23375       Evan2=-opt6*Irsixp
23376       do k=1,3
23377         dEvan2Cat(k)=dx(k)*opt7
23378         dEvan2Cm(k)=-dx(k)*opt7
23379         dEvan2Calp(k)=0.0d0
23380       enddo
23381        ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
23382       do k=1,3
23383         dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
23384                    dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
23385         dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
23386                   dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
23387         dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
23388                   +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
23389       enddo
23390           dscmag = 0.0d0
23391           do k=1,3
23392             dscvec(k) = c(k,i+nres)-c(k,i)
23393 ! TU SPRAWDZ???
23394 !              dscvec(1) = xj
23395 !              dscvec(2) = yj
23396 !              dscvec(3) = zj
23397
23398             dscmag = dscmag+dscvec(k)*dscvec(k)
23399           enddo
23400           dscmag3 = dscmag
23401           dscmag = sqrt(dscmag)
23402           dscmag3 = dscmag3*dscmag
23403           constA = 1+dASGL/dscmag
23404           constB = 0.0d0
23405           do k=1,3
23406             constB = constB+dscvec(k)*dEtotalCm(k)
23407           enddo
23408           constB = constB*dASGL/dscmag3
23409           do k=1,3
23410             gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23411             gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23412              constA*dEtotalCm(k)-constB*dscvec(k)
23413             gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
23414             gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
23415            enddo
23416          else
23417           rcal = 0.0d0
23418           do k=1,3
23419 !              r(k) = c(k,j)-c(k,i+nres)
23420             r(1) = xj
23421             r(2) = yj
23422             r(3) = zj
23423             rcal = rcal+r(k)*r(k)
23424           enddo
23425           ract=sqrt(rcal)
23426           rocal=1.5
23427           epscalc=0.2
23428           r0p=0.5*(rocal+sig0(itype(i,1)))
23429           r06 = r0p**6
23430           r012 = r06*r06
23431           Evan1=epscalc*(r012/rcal**6)
23432           Evan2=epscalc*2*(r06/rcal**3)
23433           r4 = rcal**4
23434           r7 = rcal**7
23435           do k=1,3
23436             dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
23437             dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
23438           enddo
23439           do k=1,3
23440             dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
23441           enddo
23442              ecation_prot = ecation_prot+ Evan1+Evan2
23443           do  k=1,3
23444              gradpepcatx(k,i)=gradpepcatx(k,i)+ &
23445              dEtotalCm(k)
23446             gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
23447             gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
23448            enddo
23449        endif ! 13-16 residues
23450        enddo !j
23451        enddo !i
23452        return
23453        end subroutine ecat_prot
23454
23455 !----------------------------------------------------------------------------
23456 !---------------------------------------------------------------------------
23457        subroutine ecat_nucl(ecation_nucl)
23458        integer i,j,k,subchap,itmp,inum,itypi,itypj
23459        real(kind=8) :: xi,yi,zi,xj,yj,zj
23460        real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
23461        dist_init,dist_temp,ecation_nucl,Evan1,Evan2,Ecav,Egb,wdip1,wdip2, &
23462        wvan1,wvan2,wgbsig,wgbeps,wgbchi,wgbchip,wcav1,wcav2,wcav3,wcav4, &
23463        wcavsig,wcavchi,v1m,v1dpdx,wh2o,wc,Edip,rcs2,invrcs6,invrcs8,invrcs12, &
23464        invrcs14,rcb,rcb2,invrcb,invrcb2,invrcb4,invrcb6,cosinus,cos2,dcosdcatconst, &
23465        dcosdcalpconst,dcosdcmconst,rcav,rcav11,rcav12,constcav1,constcav2, &
23466        constgb1,constgb2,constdvan1,constdvan2,sgb,sgb6,sgb7,sgb12,sgb13, &
23467        cavnum,cavdenom,invcavdenom2,dcavnumdcos,dcavnumdr,dcavdenomdcos, &
23468        dcavdenomdr,sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
23469        real(kind=8),dimension(3) ::gg,r,dEtotalCm,dEtotalCalp,dEvan1Cm,&
23470        dEvan2Cm,cm1,cm,vcat,vsug,v1,v2,dx,vcm,dEdipCm,dEdipCalp, &
23471        dEvan1Calp,dEvan2Cat,dEvan2Calp,dEtotalCat,dEdipCat,dEvan1Cat,dcosdcat, &
23472        dcosdcalp,dcosdcm,dEgbdCat,dEgbdCalp,dEgbdCm,dEcavdCat,dEcavdCalp, &
23473        dEcavdCm
23474        real(kind=8),dimension(14) :: vcatnuclprm
23475        ecation_nucl=0.0d0
23476        if (nres_molec(5).eq.0) return
23477        itmp=0
23478        do i=1,4
23479           itmp=itmp+nres_molec(i)
23480        enddo
23481        do i=iatsc_s_nucl,iatsc_e_nucl
23482           if ((itype(i,2).eq.ntyp1_molec(2))) cycle ! leave dummy atoms
23483           xi=(c(1,i+nres))
23484           yi=(c(2,i+nres))
23485           zi=(c(3,i+nres))
23486       call to_box(xi,yi,zi)
23487       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
23488           do k=1,3
23489              cm1(k)=dc(k,i+nres)
23490           enddo
23491           do j=itmp+1,itmp+nres_molec(5)
23492              xj=c(1,j)
23493              yj=c(2,j)
23494              zj=c(3,j)
23495       call to_box(xj,yj,zj)
23496 !      write(iout,*) "xi,yi,zi,xj,yj,zj", xi,yi,zi,xj,yj,zj
23497 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
23498 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23499 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23500 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23501 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23502       xj=boxshift(xj-xi,boxxsize)
23503       yj=boxshift(yj-yi,boxysize)
23504       zj=boxshift(zj-zi,boxzsize)
23505 !       write(iout,*) 'after shift', xj,yj,zj
23506              dist_init=xj**2+yj**2+zj**2
23507
23508              itypi=itype(i,2)
23509              itypj=itype(j,5)
23510              do k=1,13
23511                 vcatnuclprm(k)=catnuclprm(k,itypi,itypj)
23512              enddo
23513              do k=1,3
23514                 vcm(k)=c(k,i+nres)
23515                 vsug(k)=c(k,i)
23516                 vcat(k)=c(k,j)
23517              enddo
23518              do k=1,3
23519                 dx(k) = vcat(k)-vcm(k)
23520              enddo
23521              do k=1,3
23522                 v1(k)=dc(k,i+nres)
23523                 v2(k)=(vcat(k)-vsug(k))
23524              enddo
23525              v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23526              v1dpdx = v1(1)*dx(1)+v1(2)*dx(2)+v1(3)*dx(3)
23527 !  The weights of the energy function calculated from
23528 !The quantum mechanical Gaussian simulations of potassium and sodium with deoxynucleosides
23529              wh2o=78
23530              wdip1 = vcatnuclprm(1)
23531              wdip1 = wdip1/wh2o                     !w1
23532              wdip2 = vcatnuclprm(2)
23533              wdip2 = wdip2/wh2o                     !w2
23534              wvan1 = vcatnuclprm(3)
23535              wvan2 = vcatnuclprm(4)                 !pis1
23536              wgbsig = vcatnuclprm(5)                !sigma0
23537              wgbeps = vcatnuclprm(6)                !epsi0
23538              wgbchi = vcatnuclprm(7)                !chi1
23539              wgbchip = vcatnuclprm(8)               !chip1
23540              wcavsig = vcatnuclprm(9)               !sig
23541              wcav1 = vcatnuclprm(10)                !b1
23542              wcav2 = vcatnuclprm(11)                !b2
23543              wcav3 = vcatnuclprm(12)                !b3
23544              wcav4 = vcatnuclprm(13)                !b4
23545              wcavchi = vcatnuclprm(14)              !chis1
23546              rcs2 = v2(1)**2+v2(2)**2+v2(3)**2
23547              invrcs6 = 1/rcs2**3
23548              invrcs8 = invrcs6/rcs2
23549              invrcs12 = invrcs6**2
23550              invrcs14 = invrcs12/rcs2
23551              rcb2 = dx(1)**2+dx(2)**2+dx(3)**2
23552              rcb = sqrt(rcb2)
23553              invrcb = 1/rcb
23554              invrcb2 = invrcb**2
23555              invrcb4 = invrcb2**2
23556              invrcb6 = invrcb4*invrcb2
23557              cosinus = v1dpdx/(v1m*rcb)
23558              cos2 = cosinus**2
23559              dcosdcatconst = invrcb2/v1m
23560              dcosdcalpconst = invrcb/v1m**2
23561              dcosdcmconst = invrcb2/v1m**2
23562              do k=1,3
23563                 dcosdcat(k) = (v1(k)*rcb-dx(k)*v1m*cosinus)*dcosdcatconst
23564                 dcosdcalp(k) = (v1(k)*rcb*cosinus-dx(k)*v1m)*dcosdcalpconst
23565                 dcosdcm(k) = ((dx(k)-v1(k))*v1m*rcb+ &
23566                         cosinus*(dx(k)*v1m**2-v1(k)*rcb2))*dcosdcmconst
23567              enddo
23568              rcav = rcb/wcavsig
23569              rcav11 = rcav**11
23570              rcav12 = rcav11*rcav
23571              constcav1 = 1-wcavchi*cos2
23572              constcav2 = sqrt(constcav1)
23573              constgb1 = 1/sqrt(1-wgbchi*cos2)
23574              constgb2 = wgbeps*(1-wgbchip*cos2)**2
23575              constdvan1 = 12*wvan1*wvan2**12*invrcs14
23576              constdvan2 = 6*wvan1*wvan2**6*invrcs8
23577 !----------------------------------------------------------------------------
23578 !Gay-Berne term
23579 !---------------------------------------------------------------------------
23580              sgb = 1/(1-constgb1+(rcb/wgbsig))
23581              sgb6 = sgb**6
23582              sgb7 = sgb6*sgb
23583              sgb12 = sgb6**2
23584              sgb13 = sgb12*sgb
23585              Egb = constgb2*(sgb12-sgb6)
23586              do k=1,3
23587                 dEgbdCat(k) = -constgb2/wgbsig*(12*sgb13-6*sgb7)*invrcb*dx(k) &
23588                  +(constgb1**3*constgb2*wgbchi*cosinus*(12*sgb13-6*sgb7) &
23589      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcat(k)
23590                 dEgbdCm(k) = constgb2/wgbsig*(12*sgb13-6*sgb7)*invrcb*dx(k) &
23591                  +(constgb1**3*constgb2*wgbchi*cosinus*(12*sgb13-6*sgb7) &
23592      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcm(k)
23593                 dEgbdCalp(k) = (constgb1**3*constgb2*wgbchi*cosinus &
23594                                *(12*sgb13-6*sgb7) &
23595      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcalp(k)
23596              enddo
23597 !----------------------------------------------------------------------------
23598 !cavity term
23599 !---------------------------------------------------------------------------
23600              cavnum = sqrt(rcav*constcav2)+wcav2*rcav*constcav2-wcav3
23601              cavdenom = 1+wcav4*rcav12*constcav1**6
23602              Ecav = wcav1*cavnum/cavdenom
23603              invcavdenom2 = 1/cavdenom**2
23604              dcavnumdcos = -wcavchi*cosinus/constcav2 &
23605                     *(sqrt(rcav/constcav2)/2+wcav2*rcav)
23606              dcavnumdr = (0.5*sqrt(constcav2/rcav)+wcav2*constcav2)/wcavsig
23607              dcavdenomdcos = -12*wcav4*wcavchi*rcav12*constcav1**5*cosinus
23608              dcavdenomdr = 12*wcav4/wcavsig*rcav11*constcav1**6
23609              do k=1,3
23610                 dEcavdCat(k) = ((dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
23611      *dcosdcat(k)+(dcavnumdr*cavdenom-dcavdenomdr*cavnum)/rcb*dx(k))*wcav1*invcavdenom2
23612                 dEcavdCm(k) = ((dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
23613      *dcosdcm(k)-(dcavnumdr*cavdenom-dcavdenomdr*cavnum)/rcb*dx(k))*wcav1*invcavdenom2
23614                 dEcavdCalp(k) = (dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
23615                              *dcosdcalp(k)*wcav1*invcavdenom2
23616              enddo
23617 !----------------------------------------------------------------------------
23618 !van der Waals and dipole-charge interaction energy
23619 !---------------------------------------------------------------------------
23620              Evan1 = wvan1*wvan2**12*invrcs12
23621              do k=1,3
23622                 dEvan1Cat(k) = -v2(k)*constdvan1
23623                 dEvan1Cm(k) = 0.0d0
23624                 dEvan1Calp(k) = v2(k)*constdvan1
23625              enddo
23626              Evan2 = -wvan1*wvan2**6*invrcs6
23627              do k=1,3
23628                 dEvan2Cat(k) = v2(k)*constdvan2
23629                 dEvan2Cm(k) = 0.0d0
23630                 dEvan2Calp(k) = -v2(k)*constdvan2
23631              enddo
23632              Edip = wdip1*cosinus*invrcb2-wdip2*(1-cos2)*invrcb4
23633              do k=1,3
23634                 dEdipCat(k) = (-2*wdip1*cosinus*invrcb4 &
23635                                +4*wdip2*(1-cos2)*invrcb6)*dx(k) &
23636                    +dcosdcat(k)*(wdip1*invrcb2+2*wdip2*cosinus*invrcb4)
23637                 dEdipCm(k) = (2*wdip1*cosinus*invrcb4 &
23638                              -4*wdip2*(1-cos2)*invrcb6)*dx(k) &
23639                    +dcosdcm(k)*(wdip1*invrcb2+2*wdip2*cosinus*invrcb4)
23640                 dEdipCalp(k) = dcosdcalp(k)*(wdip1*invrcb2 &
23641                                   +2*wdip2*cosinus*invrcb4)
23642              enddo
23643              if (energy_dec) write (iout,'(2i5,4(a6,f7.3))') i,j, &
23644          ' E GB ',Egb,' ECav ',Ecav,' Evdw ',Evan1+Evan2,' Edip ',Edip
23645              ecation_nucl=ecation_nucl+Ecav+Egb+Edip+Evan1+Evan2
23646              do k=1,3
23647                 dEtotalCat(k) = dEcavdCat(k)+dEvan1Cat(k)+dEvan2Cat(k) &
23648                                              +dEgbdCat(k)+dEdipCat(k)
23649                 dEtotalCm(k) = dEcavdCm(k)+dEvan1Cm(k)+dEvan2Cm(k) &
23650                                            +dEgbdCm(k)+dEdipCm(k)
23651                 dEtotalCalp(k) = dEcavdCalp(k)+dEgbdCalp(k)+dEvan1Calp(k) &
23652                                              +dEdipCalp(k)+dEvan2Calp(k)
23653              enddo
23654              do k=1,3
23655                 gg(k) = dEtotalCm(k)+dEtotalCalp(k)
23656                 gradnuclcatx(k,i)=gradnuclcatx(k,i)+dEtotalCm(k)
23657                 gradnuclcat(k,i)=gradnuclcat(k,i)+gg(k)
23658                 gradnuclcat(k,j)=gradnuclcat(k,j)+dEtotalCat(k)
23659              enddo
23660           enddo !j
23661        enddo !i
23662        return
23663        end subroutine ecat_nucl
23664
23665 !-----------------------------------------------------------------------------
23666 !-----------------------------------------------------------------------------
23667       subroutine eprot_sc_base(escbase)
23668       use calc_data
23669 !      implicit real*8 (a-h,o-z)
23670 !      include 'DIMENSIONS'
23671 !      include 'COMMON.GEO'
23672 !      include 'COMMON.VAR'
23673 !      include 'COMMON.LOCAL'
23674 !      include 'COMMON.CHAIN'
23675 !      include 'COMMON.DERIV'
23676 !      include 'COMMON.NAMES'
23677 !      include 'COMMON.INTERACT'
23678 !      include 'COMMON.IOUNITS'
23679 !      include 'COMMON.CALC'
23680 !      include 'COMMON.CONTROL'
23681 !      include 'COMMON.SBRIDGE'
23682       logical :: lprn
23683 !el local variables
23684       integer :: iint,itypi,itypi1,itypj,subchap
23685       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23686       real(kind=8) :: evdw,sig0ij
23687       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23688                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23689                 sslipi,sslipj,faclip
23690       integer :: ii
23691       real(kind=8) :: fracinbuf
23692        real (kind=8) :: escbase
23693        real (kind=8),dimension(4):: ener
23694        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23695        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23696       sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
23697       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23698       dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
23699       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23700       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23701       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
23702        real(kind=8),dimension(3,2)::chead,erhead_tail
23703        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23704        integer troll
23705        eps_out=80.0d0
23706        escbase=0.0d0
23707 !       do i=1,nres_molec(1)
23708       do i=ibond_start,ibond_end
23709       if (itype(i,1).eq.ntyp1_molec(1)) cycle
23710       itypi  = itype(i,1)
23711       dxi    = dc_norm(1,nres+i)
23712       dyi    = dc_norm(2,nres+i)
23713       dzi    = dc_norm(3,nres+i)
23714       dsci_inv = vbld_inv(i+nres)
23715       xi=c(1,nres+i)
23716       yi=c(2,nres+i)
23717       zi=c(3,nres+i)
23718       call to_box(xi,yi,zi)
23719       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
23720        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
23721          itypj= itype(j,2)
23722          if (itype(j,2).eq.ntyp1_molec(2))cycle
23723          xj=c(1,j+nres)
23724          yj=c(2,j+nres)
23725          zj=c(3,j+nres)
23726       call to_box(xj,yj,zj)
23727 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
23728 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23729 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23730 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23731 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23732       xj=boxshift(xj-xi,boxxsize)
23733       yj=boxshift(yj-yi,boxysize)
23734       zj=boxshift(zj-zi,boxzsize)
23735
23736         dxj = dc_norm( 1, nres+j )
23737         dyj = dc_norm( 2, nres+j )
23738         dzj = dc_norm( 3, nres+j )
23739 !          print *,i,j,itypi,itypj
23740         d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
23741         d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
23742 !          d1i=0.0d0
23743 !          d1j=0.0d0
23744 !          BetaT = 1.0d0 / (298.0d0 * Rb)
23745 ! Gay-berne var's
23746         sig0ij = sigma_scbase( itypi,itypj )
23747         chi1   = chi_scbase( itypi, itypj,1 )
23748         chi2   = chi_scbase( itypi, itypj,2 )
23749 !          chi1=0.0d0
23750 !          chi2=0.0d0
23751         chi12  = chi1 * chi2
23752         chip1  = chipp_scbase( itypi, itypj,1 )
23753         chip2  = chipp_scbase( itypi, itypj,2 )
23754 !          chip1=0.0d0
23755 !          chip2=0.0d0
23756         chip12 = chip1 * chip2
23757 ! not used by momo potential, but needed by sc_angular which is shared
23758 ! by all energy_potential subroutines
23759         alf1   = 0.0d0
23760         alf2   = 0.0d0
23761         alf12  = 0.0d0
23762         a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
23763 !       a12sq = a12sq * a12sq
23764 ! charge of amino acid itypi is...
23765         chis1 = chis_scbase(itypi,itypj,1)
23766         chis2 = chis_scbase(itypi,itypj,2)
23767         chis12 = chis1 * chis2
23768         sig1 = sigmap1_scbase(itypi,itypj)
23769         sig2 = sigmap2_scbase(itypi,itypj)
23770 !       write (*,*) "sig1 = ", sig1
23771 !       write (*,*) "sig2 = ", sig2
23772 ! alpha factors from Fcav/Gcav
23773         b1 = alphasur_scbase(1,itypi,itypj)
23774 !          b1=0.0d0
23775         b2 = alphasur_scbase(2,itypi,itypj)
23776         b3 = alphasur_scbase(3,itypi,itypj)
23777         b4 = alphasur_scbase(4,itypi,itypj)
23778 ! used to determine whether we want to do quadrupole calculations
23779 ! used by Fgb
23780        eps_in = epsintab_scbase(itypi,itypj)
23781        if (eps_in.eq.0.0) eps_in=1.0
23782        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23783 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
23784 !-------------------------------------------------------------------
23785 ! tail location and distance calculations
23786        DO k = 1,3
23787 ! location of polar head is computed by taking hydrophobic centre
23788 ! and moving by a d1 * dc_norm vector
23789 ! see unres publications for very informative images
23790       chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
23791       chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
23792 ! distance
23793 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23794 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23795       Rhead_distance(k) = chead(k,2) - chead(k,1)
23796        END DO
23797 ! pitagoras (root of sum of squares)
23798        Rhead = dsqrt( &
23799         (Rhead_distance(1)*Rhead_distance(1)) &
23800       + (Rhead_distance(2)*Rhead_distance(2)) &
23801       + (Rhead_distance(3)*Rhead_distance(3)))
23802 !-------------------------------------------------------------------
23803 ! zero everything that should be zero'ed
23804        evdwij = 0.0d0
23805        ECL = 0.0d0
23806        Elj = 0.0d0
23807        Equad = 0.0d0
23808        Epol = 0.0d0
23809        Fcav=0.0d0
23810        eheadtail = 0.0d0
23811        dGCLdOM1 = 0.0d0
23812        dGCLdOM2 = 0.0d0
23813        dGCLdOM12 = 0.0d0
23814        dPOLdOM1 = 0.0d0
23815        dPOLdOM2 = 0.0d0
23816         Fcav = 0.0d0
23817         dFdR = 0.0d0
23818         dCAVdOM1  = 0.0d0
23819         dCAVdOM2  = 0.0d0
23820         dCAVdOM12 = 0.0d0
23821         dscj_inv = vbld_inv(j+nres)
23822 !          print *,i,j,dscj_inv,dsci_inv
23823 ! rij holds 1/(distance of Calpha atoms)
23824         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23825         rij  = dsqrt(rrij)
23826 !----------------------------
23827         CALL sc_angular
23828 ! this should be in elgrad_init but om's are calculated by sc_angular
23829 ! which in turn is used by older potentials
23830 ! om = omega, sqom = om^2
23831         sqom1  = om1 * om1
23832         sqom2  = om2 * om2
23833         sqom12 = om12 * om12
23834
23835 ! now we calculate EGB - Gey-Berne
23836 ! It will be summed up in evdwij and saved in evdw
23837         sigsq     = 1.0D0  / sigsq
23838         sig       = sig0ij * dsqrt(sigsq)
23839 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23840         rij_shift = 1.0/rij - sig + sig0ij
23841         IF (rij_shift.le.0.0D0) THEN
23842          evdw = 1.0D20
23843          RETURN
23844         END IF
23845         sigder = -sig * sigsq
23846         rij_shift = 1.0D0 / rij_shift
23847         fac       = rij_shift**expon
23848         c1        = fac  * fac * aa_scbase(itypi,itypj)
23849 !          c1        = 0.0d0
23850         c2        = fac  * bb_scbase(itypi,itypj)
23851 !          c2        = 0.0d0
23852         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23853         eps2der   = eps3rt * evdwij
23854         eps3der   = eps2rt * evdwij
23855 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23856         evdwij    = eps2rt * eps3rt * evdwij
23857         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23858         fac    = -expon * (c1 + evdwij) * rij_shift
23859         sigder = fac * sigder
23860 !          fac    = rij * fac
23861 ! Calculate distance derivative
23862         gg(1) =  fac
23863         gg(2) =  fac
23864         gg(3) =  fac
23865 !          if (b2.gt.0.0) then
23866         fac = chis1 * sqom1 + chis2 * sqom2 &
23867         - 2.0d0 * chis12 * om1 * om2 * om12
23868 ! we will use pom later in Gcav, so dont mess with it!
23869         pom = 1.0d0 - chis1 * chis2 * sqom12
23870         Lambf = (1.0d0 - (fac / pom))
23871         Lambf = dsqrt(Lambf)
23872         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23873 !       write (*,*) "sparrow = ", sparrow
23874         Chif = 1.0d0/rij * sparrow
23875         ChiLambf = Chif * Lambf
23876         eagle = dsqrt(ChiLambf)
23877         bat = ChiLambf ** 11.0d0
23878         top = b1 * ( eagle + b2 * ChiLambf - b3 )
23879         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23880         botsq = bot * bot
23881         Fcav = top / bot
23882 !          print *,i,j,Fcav
23883         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23884         dbot = 12.0d0 * b4 * bat * Lambf
23885         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23886 !       dFdR = 0.0d0
23887 !      write (*,*) "dFcav/dR = ", dFdR
23888         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23889         dbot = 12.0d0 * b4 * bat * Chif
23890         eagle = Lambf * pom
23891         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23892         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23893         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23894             * (chis2 * om2 * om12 - om1) / (eagle * pom)
23895
23896         dFdL = ((dtop * bot - top * dbot) / botsq)
23897 !       dFdL = 0.0d0
23898         dCAVdOM1  = dFdL * ( dFdOM1 )
23899         dCAVdOM2  = dFdL * ( dFdOM2 )
23900         dCAVdOM12 = dFdL * ( dFdOM12 )
23901
23902         ertail(1) = xj*rij
23903         ertail(2) = yj*rij
23904         ertail(3) = zj*rij
23905 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
23906 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
23907 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
23908 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
23909 !           print *,"EOMY",eom1,eom2,eom12
23910 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
23911 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
23912 ! here dtail=0.0
23913 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
23914 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23915        DO k = 1, 3
23916 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23917 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23918       pom = ertail(k)
23919 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23920       gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
23921               - (( dFdR + gg(k) ) * pom)
23922 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23923 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23924 !     &             - ( dFdR * pom )
23925       pom = ertail(k)
23926 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23927       gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
23928               + (( dFdR + gg(k) ) * pom)
23929 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23930 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23931 !c!     &             + ( dFdR * pom )
23932
23933       gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
23934               - (( dFdR + gg(k) ) * ertail(k))
23935 !c!     &             - ( dFdR * ertail(k))
23936
23937       gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
23938               + (( dFdR + gg(k) ) * ertail(k))
23939 !c!     &             + ( dFdR * ertail(k))
23940
23941       gg(k) = 0.0d0
23942 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23943 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23944       END DO
23945
23946 !          else
23947
23948 !          endif
23949 !Now dipole-dipole
23950        if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
23951        w1 = wdipdip_scbase(1,itypi,itypj)
23952        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
23953        w3 = wdipdip_scbase(2,itypi,itypj)
23954 !c!-------------------------------------------------------------------
23955 !c! ECL
23956        fac = (om12 - 3.0d0 * om1 * om2)
23957        c1 = (w1 / (Rhead**3.0d0)) * fac
23958        c2 = (w2 / Rhead ** 6.0d0)  &
23959        * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23960        c3= (w3/ Rhead ** 6.0d0)  &
23961        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23962        ECL = c1 - c2 + c3
23963 !c!       write (*,*) "w1 = ", w1
23964 !c!       write (*,*) "w2 = ", w2
23965 !c!       write (*,*) "om1 = ", om1
23966 !c!       write (*,*) "om2 = ", om2
23967 !c!       write (*,*) "om12 = ", om12
23968 !c!       write (*,*) "fac = ", fac
23969 !c!       write (*,*) "c1 = ", c1
23970 !c!       write (*,*) "c2 = ", c2
23971 !c!       write (*,*) "Ecl = ", Ecl
23972 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
23973 !c!       write (*,*) "c2_2 = ",
23974 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23975 !c!-------------------------------------------------------------------
23976 !c! dervative of ECL is GCL...
23977 !c! dECL/dr
23978        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
23979        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
23980        * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
23981        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
23982        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23983        dGCLdR = c1 - c2 + c3
23984 !c! dECL/dom1
23985        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
23986        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23987        * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
23988        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
23989        dGCLdOM1 = c1 - c2 + c3
23990 !c! dECL/dom2
23991        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
23992        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23993        * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
23994        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
23995        dGCLdOM2 = c1 - c2 + c3
23996 !c! dECL/dom12
23997        c1 = w1 / (Rhead ** 3.0d0)
23998        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
23999        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
24000        dGCLdOM12 = c1 - c2 + c3
24001        DO k= 1, 3
24002       erhead(k) = Rhead_distance(k)/Rhead
24003        END DO
24004        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24005        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24006        facd1 = d1i * vbld_inv(i+nres)
24007        facd2 = d1j * vbld_inv(j+nres)
24008        DO k = 1, 3
24009
24010       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24011       gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
24012               - dGCLdR * pom
24013       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24014       gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
24015               + dGCLdR * pom
24016
24017       gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
24018               - dGCLdR * erhead(k)
24019       gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
24020               + dGCLdR * erhead(k)
24021        END DO
24022        endif
24023 !now charge with dipole eg. ARG-dG
24024        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
24025       alphapol1 = alphapol_scbase(itypi,itypj)
24026        w1        = wqdip_scbase(1,itypi,itypj)
24027        w2        = wqdip_scbase(2,itypi,itypj)
24028 !       w1=0.0d0
24029 !       w2=0.0d0
24030 !       pis       = sig0head_scbase(itypi,itypj)
24031 !       eps_head   = epshead_scbase(itypi,itypj)
24032 !c!-------------------------------------------------------------------
24033 !c! R1 - distance between head of ith side chain and tail of jth sidechain
24034        R1 = 0.0d0
24035        DO k = 1, 3
24036 !c! Calculate head-to-tail distances tail is center of side-chain
24037       R1=R1+(c(k,j+nres)-chead(k,1))**2
24038        END DO
24039 !c! Pitagoras
24040        R1 = dsqrt(R1)
24041
24042 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24043 !c!     &        +dhead(1,1,itypi,itypj))**2))
24044 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24045 !c!     &        +dhead(2,1,itypi,itypj))**2))
24046
24047 !c!-------------------------------------------------------------------
24048 !c! ecl
24049        sparrow  = w1  *  om1
24050        hawk     = w2 *  (1.0d0 - sqom2)
24051        Ecl = sparrow / Rhead**2.0d0 &
24052          - hawk    / Rhead**4.0d0
24053 !c!-------------------------------------------------------------------
24054 !c! derivative of ecl is Gcl
24055 !c! dF/dr part
24056        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
24057             + 4.0d0 * hawk    / Rhead**5.0d0
24058 !c! dF/dom1
24059        dGCLdOM1 = (w1) / (Rhead**2.0d0)
24060 !c! dF/dom2
24061        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
24062 !c--------------------------------------------------------------------
24063 !c Polarization energy
24064 !c Epol
24065        MomoFac1 = (1.0d0 - chi1 * sqom2)
24066        RR1  = R1 * R1 / MomoFac1
24067        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24068        fgb1 = sqrt( RR1 + a12sq * ee1)
24069 !       eps_inout_fac=0.0d0
24070        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
24071 ! derivative of Epol is Gpol...
24072        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
24073             / (fgb1 ** 5.0d0)
24074        dFGBdR1 = ( (R1 / MomoFac1) &
24075            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
24076            / ( 2.0d0 * fgb1 )
24077        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
24078              * (2.0d0 - 0.5d0 * ee1) ) &
24079              / (2.0d0 * fgb1)
24080        dPOLdR1 = dPOLdFGB1 * dFGBdR1
24081 !       dPOLdR1 = 0.0d0
24082        dPOLdOM1 = 0.0d0
24083        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
24084        DO k = 1, 3
24085       erhead(k) = Rhead_distance(k)/Rhead
24086       erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
24087        END DO
24088
24089        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24090        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24091        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
24092 !       bat=0.0d0
24093        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
24094        facd1 = d1i * vbld_inv(i+nres)
24095        facd2 = d1j * vbld_inv(j+nres)
24096 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24097
24098        DO k = 1, 3
24099       hawk = (erhead_tail(k,1) + &
24100       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
24101 !        facd1=0.0d0
24102 !        facd2=0.0d0
24103       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24104       gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
24105                - dGCLdR * pom &
24106                - dPOLdR1 *  (erhead_tail(k,1))
24107 !     &             - dGLJdR * pom
24108
24109       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24110       gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
24111                + dGCLdR * pom  &
24112                + dPOLdR1 * (erhead_tail(k,1))
24113 !     &             + dGLJdR * pom
24114
24115
24116       gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
24117               - dGCLdR * erhead(k) &
24118               - dPOLdR1 * erhead_tail(k,1)
24119 !     &             - dGLJdR * erhead(k)
24120
24121       gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
24122               + dGCLdR * erhead(k)  &
24123               + dPOLdR1 * erhead_tail(k,1)
24124 !     &             + dGLJdR * erhead(k)
24125
24126        END DO
24127        endif
24128 !       print *,i,j,evdwij,epol,Fcav,ECL
24129        escbase=escbase+evdwij+epol+Fcav+ECL
24130        call sc_grad_scbase
24131        enddo
24132       enddo
24133
24134       return
24135       end subroutine eprot_sc_base
24136       SUBROUTINE sc_grad_scbase
24137       use calc_data
24138
24139        real (kind=8) :: dcosom1(3),dcosom2(3)
24140        eom1  =    &
24141             eps2der * eps2rt_om1   &
24142           - 2.0D0 * alf1 * eps3der &
24143           + sigder * sigsq_om1     &
24144           + dCAVdOM1               &
24145           + dGCLdOM1               &
24146           + dPOLdOM1
24147
24148        eom2  =  &
24149             eps2der * eps2rt_om2   &
24150           + 2.0D0 * alf2 * eps3der &
24151           + sigder * sigsq_om2     &
24152           + dCAVdOM2               &
24153           + dGCLdOM2               &
24154           + dPOLdOM2
24155
24156        eom12 =    &
24157             evdwij  * eps1_om12     &
24158           + eps2der * eps2rt_om12   &
24159           - 2.0D0 * alf12 * eps3der &
24160           + sigder *sigsq_om12      &
24161           + dCAVdOM12               &
24162           + dGCLdOM12
24163
24164 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24165 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24166 !               gg(1),gg(2),"rozne"
24167        DO k = 1, 3
24168       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
24169       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24170       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24171       gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
24172              + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24173              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24174       gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
24175              + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24176              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24177       gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
24178       gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
24179        END DO
24180        RETURN
24181       END SUBROUTINE sc_grad_scbase
24182
24183
24184       subroutine epep_sc_base(epepbase)
24185       use calc_data
24186       logical :: lprn
24187 !el local variables
24188       integer :: iint,itypi,itypi1,itypj,subchap
24189       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24190       real(kind=8) :: evdw,sig0ij
24191       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24192                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24193                 sslipi,sslipj,faclip
24194       integer :: ii
24195       real(kind=8) :: fracinbuf
24196        real (kind=8) :: epepbase
24197        real (kind=8),dimension(4):: ener
24198        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24199        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24200       sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
24201       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24202       dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
24203       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24204       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24205       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
24206        real(kind=8),dimension(3,2)::chead,erhead_tail
24207        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24208        integer troll
24209        eps_out=80.0d0
24210        epepbase=0.0d0
24211 !       do i=1,nres_molec(1)-1
24212       do i=ibond_start,ibond_end
24213       if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
24214 !C        itypi  = itype(i,1)
24215       dxi    = dc_norm(1,i)
24216       dyi    = dc_norm(2,i)
24217       dzi    = dc_norm(3,i)
24218 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
24219       dsci_inv = vbld_inv(i+1)/2.0
24220       xi=(c(1,i)+c(1,i+1))/2.0
24221       yi=(c(2,i)+c(2,i+1))/2.0
24222       zi=(c(3,i)+c(3,i+1))/2.0
24223         call to_box(xi,yi,zi)
24224        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
24225          itypj= itype(j,2)
24226          if (itype(j,2).eq.ntyp1_molec(2))cycle
24227          xj=c(1,j+nres)
24228          yj=c(2,j+nres)
24229          zj=c(3,j+nres)
24230                 call to_box(xj,yj,zj)
24231       xj=boxshift(xj-xi,boxxsize)
24232       yj=boxshift(yj-yi,boxysize)
24233       zj=boxshift(zj-zi,boxzsize)
24234         dist_init=xj**2+yj**2+zj**2
24235         dxj = dc_norm( 1, nres+j )
24236         dyj = dc_norm( 2, nres+j )
24237         dzj = dc_norm( 3, nres+j )
24238 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
24239 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
24240
24241 ! Gay-berne var's
24242         sig0ij = sigma_pepbase(itypj )
24243         chi1   = chi_pepbase(itypj,1 )
24244         chi2   = chi_pepbase(itypj,2 )
24245 !          chi1=0.0d0
24246 !          chi2=0.0d0
24247         chi12  = chi1 * chi2
24248         chip1  = chipp_pepbase(itypj,1 )
24249         chip2  = chipp_pepbase(itypj,2 )
24250 !          chip1=0.0d0
24251 !          chip2=0.0d0
24252         chip12 = chip1 * chip2
24253         chis1 = chis_pepbase(itypj,1)
24254         chis2 = chis_pepbase(itypj,2)
24255         chis12 = chis1 * chis2
24256         sig1 = sigmap1_pepbase(itypj)
24257         sig2 = sigmap2_pepbase(itypj)
24258 !       write (*,*) "sig1 = ", sig1
24259 !       write (*,*) "sig2 = ", sig2
24260        DO k = 1,3
24261 ! location of polar head is computed by taking hydrophobic centre
24262 ! and moving by a d1 * dc_norm vector
24263 ! see unres publications for very informative images
24264       chead(k,1) = (c(k,i)+c(k,i+1))/2.0
24265 ! + d1i * dc_norm(k, i+nres)
24266       chead(k,2) = c(k, j+nres)
24267 ! + d1j * dc_norm(k, j+nres)
24268 ! distance
24269 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24270 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24271       Rhead_distance(k) = chead(k,2) - chead(k,1)
24272 !        print *,gvdwc_pepbase(k,i)
24273
24274        END DO
24275        Rhead = dsqrt( &
24276         (Rhead_distance(1)*Rhead_distance(1)) &
24277       + (Rhead_distance(2)*Rhead_distance(2)) &
24278       + (Rhead_distance(3)*Rhead_distance(3)))
24279
24280 ! alpha factors from Fcav/Gcav
24281         b1 = alphasur_pepbase(1,itypj)
24282 !          b1=0.0d0
24283         b2 = alphasur_pepbase(2,itypj)
24284         b3 = alphasur_pepbase(3,itypj)
24285         b4 = alphasur_pepbase(4,itypj)
24286         alf1   = 0.0d0
24287         alf2   = 0.0d0
24288         alf12  = 0.0d0
24289         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24290 !          print *,i,j,rrij
24291         rij  = dsqrt(rrij)
24292 !----------------------------
24293        evdwij = 0.0d0
24294        ECL = 0.0d0
24295        Elj = 0.0d0
24296        Equad = 0.0d0
24297        Epol = 0.0d0
24298        Fcav=0.0d0
24299        eheadtail = 0.0d0
24300        dGCLdOM1 = 0.0d0
24301        dGCLdOM2 = 0.0d0
24302        dGCLdOM12 = 0.0d0
24303        dPOLdOM1 = 0.0d0
24304        dPOLdOM2 = 0.0d0
24305         Fcav = 0.0d0
24306         dFdR = 0.0d0
24307         dCAVdOM1  = 0.0d0
24308         dCAVdOM2  = 0.0d0
24309         dCAVdOM12 = 0.0d0
24310         dscj_inv = vbld_inv(j+nres)
24311         CALL sc_angular
24312 ! this should be in elgrad_init but om's are calculated by sc_angular
24313 ! which in turn is used by older potentials
24314 ! om = omega, sqom = om^2
24315         sqom1  = om1 * om1
24316         sqom2  = om2 * om2
24317         sqom12 = om12 * om12
24318
24319 ! now we calculate EGB - Gey-Berne
24320 ! It will be summed up in evdwij and saved in evdw
24321         sigsq     = 1.0D0  / sigsq
24322         sig       = sig0ij * dsqrt(sigsq)
24323         rij_shift = 1.0/rij - sig + sig0ij
24324         IF (rij_shift.le.0.0D0) THEN
24325          evdw = 1.0D20
24326          RETURN
24327         END IF
24328         sigder = -sig * sigsq
24329         rij_shift = 1.0D0 / rij_shift
24330         fac       = rij_shift**expon
24331         c1        = fac  * fac * aa_pepbase(itypj)
24332 !          c1        = 0.0d0
24333         c2        = fac  * bb_pepbase(itypj)
24334 !          c2        = 0.0d0
24335         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24336         eps2der   = eps3rt * evdwij
24337         eps3der   = eps2rt * evdwij
24338 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24339         evdwij    = eps2rt * eps3rt * evdwij
24340         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24341         fac    = -expon * (c1 + evdwij) * rij_shift
24342         sigder = fac * sigder
24343 !          fac    = rij * fac
24344 ! Calculate distance derivative
24345         gg(1) =  fac
24346         gg(2) =  fac
24347         gg(3) =  fac
24348         fac = chis1 * sqom1 + chis2 * sqom2 &
24349         - 2.0d0 * chis12 * om1 * om2 * om12
24350 ! we will use pom later in Gcav, so dont mess with it!
24351         pom = 1.0d0 - chis1 * chis2 * sqom12
24352         Lambf = (1.0d0 - (fac / pom))
24353         Lambf = dsqrt(Lambf)
24354         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24355 !       write (*,*) "sparrow = ", sparrow
24356         Chif = 1.0d0/rij * sparrow
24357         ChiLambf = Chif * Lambf
24358         eagle = dsqrt(ChiLambf)
24359         bat = ChiLambf ** 11.0d0
24360         top = b1 * ( eagle + b2 * ChiLambf - b3 )
24361         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24362         botsq = bot * bot
24363         Fcav = top / bot
24364 !          print *,i,j,Fcav
24365         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24366         dbot = 12.0d0 * b4 * bat * Lambf
24367         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24368 !       dFdR = 0.0d0
24369 !      write (*,*) "dFcav/dR = ", dFdR
24370         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24371         dbot = 12.0d0 * b4 * bat * Chif
24372         eagle = Lambf * pom
24373         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24374         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24375         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24376             * (chis2 * om2 * om12 - om1) / (eagle * pom)
24377
24378         dFdL = ((dtop * bot - top * dbot) / botsq)
24379 !       dFdL = 0.0d0
24380         dCAVdOM1  = dFdL * ( dFdOM1 )
24381         dCAVdOM2  = dFdL * ( dFdOM2 )
24382         dCAVdOM12 = dFdL * ( dFdOM12 )
24383
24384         ertail(1) = xj*rij
24385         ertail(2) = yj*rij
24386         ertail(3) = zj*rij
24387        DO k = 1, 3
24388 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24389 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24390       pom = ertail(k)
24391 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24392       gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24393               - (( dFdR + gg(k) ) * pom)/2.0
24394 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
24395 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24396 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24397 !     &             - ( dFdR * pom )
24398       pom = ertail(k)
24399 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24400       gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24401               + (( dFdR + gg(k) ) * pom)
24402 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24403 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24404 !c!     &             + ( dFdR * pom )
24405
24406       gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24407               - (( dFdR + gg(k) ) * ertail(k))/2.0
24408 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
24409
24410 !c!     &             - ( dFdR * ertail(k))
24411
24412       gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24413               + (( dFdR + gg(k) ) * ertail(k))
24414 !c!     &             + ( dFdR * ertail(k))
24415
24416       gg(k) = 0.0d0
24417 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24418 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24419       END DO
24420
24421
24422        w1 = wdipdip_pepbase(1,itypj)
24423        w2 = -wdipdip_pepbase(3,itypj)/2.0
24424        w3 = wdipdip_pepbase(2,itypj)
24425 !       w1=0.0d0
24426 !       w2=0.0d0
24427 !c!-------------------------------------------------------------------
24428 !c! ECL
24429 !       w3=0.0d0
24430        fac = (om12 - 3.0d0 * om1 * om2)
24431        c1 = (w1 / (Rhead**3.0d0)) * fac
24432        c2 = (w2 / Rhead ** 6.0d0)  &
24433        * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24434        c3= (w3/ Rhead ** 6.0d0)  &
24435        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24436
24437        ECL = c1 - c2 + c3
24438
24439        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
24440        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
24441        * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
24442        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
24443        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24444
24445        dGCLdR = c1 - c2 + c3
24446 !c! dECL/dom1
24447        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
24448        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24449        * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
24450        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
24451        dGCLdOM1 = c1 - c2 + c3
24452 !c! dECL/dom2
24453        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
24454        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24455        * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
24456        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
24457
24458        dGCLdOM2 = c1 - c2 + c3
24459 !c! dECL/dom12
24460        c1 = w1 / (Rhead ** 3.0d0)
24461        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
24462        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
24463        dGCLdOM12 = c1 - c2 + c3
24464        DO k= 1, 3
24465       erhead(k) = Rhead_distance(k)/Rhead
24466        END DO
24467        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24468        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24469 !       facd1 = d1 * vbld_inv(i+nres)
24470 !       facd2 = d2 * vbld_inv(j+nres)
24471        DO k = 1, 3
24472
24473 !        pom = erhead(k)
24474 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24475 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
24476 !                  - dGCLdR * pom
24477       pom = erhead(k)
24478 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24479       gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
24480               + dGCLdR * pom
24481
24482       gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
24483               - dGCLdR * erhead(k)/2.0d0
24484 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24485       gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
24486               - dGCLdR * erhead(k)/2.0d0
24487 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
24488       gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
24489               + dGCLdR * erhead(k)
24490        END DO
24491 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
24492        epepbase=epepbase+evdwij+Fcav+ECL
24493        call sc_grad_pepbase
24494        enddo
24495        enddo
24496       END SUBROUTINE epep_sc_base
24497       SUBROUTINE sc_grad_pepbase
24498       use calc_data
24499
24500        real (kind=8) :: dcosom1(3),dcosom2(3)
24501        eom1  =    &
24502             eps2der * eps2rt_om1   &
24503           - 2.0D0 * alf1 * eps3der &
24504           + sigder * sigsq_om1     &
24505           + dCAVdOM1               &
24506           + dGCLdOM1               &
24507           + dPOLdOM1
24508
24509        eom2  =  &
24510             eps2der * eps2rt_om2   &
24511           + 2.0D0 * alf2 * eps3der &
24512           + sigder * sigsq_om2     &
24513           + dCAVdOM2               &
24514           + dGCLdOM2               &
24515           + dPOLdOM2
24516
24517        eom12 =    &
24518             evdwij  * eps1_om12     &
24519           + eps2der * eps2rt_om12   &
24520           - 2.0D0 * alf12 * eps3der &
24521           + sigder *sigsq_om12      &
24522           + dCAVdOM12               &
24523           + dGCLdOM12
24524 !        om12=0.0
24525 !        eom12=0.0
24526 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24527 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
24528 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24529 !                 *dsci_inv*2.0
24530 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24531 !               gg(1),gg(2),"rozne"
24532        DO k = 1, 3
24533       dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
24534       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24535       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24536       gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
24537              + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24538              *dsci_inv*2.0 &
24539              - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24540       gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
24541              - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
24542              *dsci_inv*2.0 &
24543              + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24544 !         print *,eom12,eom2,om12,om2
24545 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
24546 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
24547       gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
24548              + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
24549              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24550       gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
24551        END DO
24552        RETURN
24553       END SUBROUTINE sc_grad_pepbase
24554       subroutine eprot_sc_phosphate(escpho)
24555       use calc_data
24556 !      implicit real*8 (a-h,o-z)
24557 !      include 'DIMENSIONS'
24558 !      include 'COMMON.GEO'
24559 !      include 'COMMON.VAR'
24560 !      include 'COMMON.LOCAL'
24561 !      include 'COMMON.CHAIN'
24562 !      include 'COMMON.DERIV'
24563 !      include 'COMMON.NAMES'
24564 !      include 'COMMON.INTERACT'
24565 !      include 'COMMON.IOUNITS'
24566 !      include 'COMMON.CALC'
24567 !      include 'COMMON.CONTROL'
24568 !      include 'COMMON.SBRIDGE'
24569       logical :: lprn
24570 !el local variables
24571       integer :: iint,itypi,itypi1,itypj,subchap
24572       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24573       real(kind=8) :: evdw,sig0ij,aa,bb
24574       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24575                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
24576                 sslipi,sslipj,faclip,alpha_sco
24577       integer :: ii
24578       real(kind=8) :: fracinbuf
24579        real (kind=8) :: escpho
24580        real (kind=8),dimension(4):: ener
24581        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24582        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24583       sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
24584       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24585       dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
24586       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24587       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24588       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
24589        real(kind=8),dimension(3,2)::chead,erhead_tail
24590        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24591        integer troll
24592        eps_out=80.0d0
24593        escpho=0.0d0
24594 !       do i=1,nres_molec(1)
24595       do i=ibond_start,ibond_end
24596       if (itype(i,1).eq.ntyp1_molec(1)) cycle
24597       itypi  = itype(i,1)
24598       dxi    = dc_norm(1,nres+i)
24599       dyi    = dc_norm(2,nres+i)
24600       dzi    = dc_norm(3,nres+i)
24601       dsci_inv = vbld_inv(i+nres)
24602       xi=c(1,nres+i)
24603       yi=c(2,nres+i)
24604       zi=c(3,nres+i)
24605        call to_box(xi,yi,zi)
24606       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
24607        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
24608          itypj= itype(j,2)
24609          if ((itype(j,2).eq.ntyp1_molec(2)).or.&
24610           (itype(j+1,2).eq.ntyp1_molec(2))) cycle
24611          xj=(c(1,j)+c(1,j+1))/2.0
24612          yj=(c(2,j)+c(2,j+1))/2.0
24613          zj=(c(3,j)+c(3,j+1))/2.0
24614      call to_box(xj,yj,zj)
24615 !     call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
24616 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
24617 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
24618 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
24619 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
24620       xj=boxshift(xj-xi,boxxsize)
24621       yj=boxshift(yj-yi,boxysize)
24622       zj=boxshift(zj-zi,boxzsize)
24623           dxj = dc_norm( 1,j )
24624         dyj = dc_norm( 2,j )
24625         dzj = dc_norm( 3,j )
24626         dscj_inv = vbld_inv(j+1)
24627
24628 ! Gay-berne var's
24629         sig0ij = sigma_scpho(itypi )
24630         chi1   = chi_scpho(itypi,1 )
24631         chi2   = chi_scpho(itypi,2 )
24632 !          chi1=0.0d0
24633 !          chi2=0.0d0
24634         chi12  = chi1 * chi2
24635         chip1  = chipp_scpho(itypi,1 )
24636         chip2  = chipp_scpho(itypi,2 )
24637 !          chip1=0.0d0
24638 !          chip2=0.0d0
24639         chip12 = chip1 * chip2
24640         chis1 = chis_scpho(itypi,1)
24641         chis2 = chis_scpho(itypi,2)
24642         chis12 = chis1 * chis2
24643         sig1 = sigmap1_scpho(itypi)
24644         sig2 = sigmap2_scpho(itypi)
24645 !       write (*,*) "sig1 = ", sig1
24646 !       write (*,*) "sig1 = ", sig1
24647 !       write (*,*) "sig2 = ", sig2
24648 ! alpha factors from Fcav/Gcav
24649         alf1   = 0.0d0
24650         alf2   = 0.0d0
24651         alf12  = 0.0d0
24652         a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
24653
24654         b1 = alphasur_scpho(1,itypi)
24655 !          b1=0.0d0
24656         b2 = alphasur_scpho(2,itypi)
24657         b3 = alphasur_scpho(3,itypi)
24658         b4 = alphasur_scpho(4,itypi)
24659 ! used to determine whether we want to do quadrupole calculations
24660 ! used by Fgb
24661        eps_in = epsintab_scpho(itypi)
24662        if (eps_in.eq.0.0) eps_in=1.0
24663        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
24664 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
24665 !-------------------------------------------------------------------
24666 ! tail location and distance calculations
24667         d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
24668         d1j = 0.0
24669        DO k = 1,3
24670 ! location of polar head is computed by taking hydrophobic centre
24671 ! and moving by a d1 * dc_norm vector
24672 ! see unres publications for very informative images
24673       chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
24674       chead(k,2) = (c(k, j) + c(k, j+1))/2.0
24675 ! distance
24676 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24677 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24678       Rhead_distance(k) = chead(k,2) - chead(k,1)
24679        END DO
24680 ! pitagoras (root of sum of squares)
24681        Rhead = dsqrt( &
24682         (Rhead_distance(1)*Rhead_distance(1)) &
24683       + (Rhead_distance(2)*Rhead_distance(2)) &
24684       + (Rhead_distance(3)*Rhead_distance(3)))
24685        Rhead_sq=Rhead**2.0
24686 !-------------------------------------------------------------------
24687 ! zero everything that should be zero'ed
24688        evdwij = 0.0d0
24689        ECL = 0.0d0
24690        Elj = 0.0d0
24691        Equad = 0.0d0
24692        Epol = 0.0d0
24693        Fcav=0.0d0
24694        eheadtail = 0.0d0
24695        dGCLdR=0.0d0
24696        dGCLdOM1 = 0.0d0
24697        dGCLdOM2 = 0.0d0
24698        dGCLdOM12 = 0.0d0
24699        dPOLdOM1 = 0.0d0
24700        dPOLdOM2 = 0.0d0
24701         Fcav = 0.0d0
24702         dFdR = 0.0d0
24703         dCAVdOM1  = 0.0d0
24704         dCAVdOM2  = 0.0d0
24705         dCAVdOM12 = 0.0d0
24706         dscj_inv = vbld_inv(j+1)/2.0
24707 !dhead_scbasej(itypi,itypj)
24708 !          print *,i,j,dscj_inv,dsci_inv
24709 ! rij holds 1/(distance of Calpha atoms)
24710         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24711         rij  = dsqrt(rrij)
24712 !----------------------------
24713         CALL sc_angular
24714 ! this should be in elgrad_init but om's are calculated by sc_angular
24715 ! which in turn is used by older potentials
24716 ! om = omega, sqom = om^2
24717         sqom1  = om1 * om1
24718         sqom2  = om2 * om2
24719         sqom12 = om12 * om12
24720
24721 ! now we calculate EGB - Gey-Berne
24722 ! It will be summed up in evdwij and saved in evdw
24723         sigsq     = 1.0D0  / sigsq
24724         sig       = sig0ij * dsqrt(sigsq)
24725 !          rij_shift = 1.0D0  / rij - sig + sig0ij
24726         rij_shift = 1.0/rij - sig + sig0ij
24727         IF (rij_shift.le.0.0D0) THEN
24728          evdw = 1.0D20
24729          RETURN
24730         END IF
24731         sigder = -sig * sigsq
24732         rij_shift = 1.0D0 / rij_shift
24733         fac       = rij_shift**expon
24734         c1        = fac  * fac * aa_scpho(itypi)
24735 !          c1        = 0.0d0
24736         c2        = fac  * bb_scpho(itypi)
24737 !          c2        = 0.0d0
24738         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24739         eps2der   = eps3rt * evdwij
24740         eps3der   = eps2rt * evdwij
24741 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24742         evdwij    = eps2rt * eps3rt * evdwij
24743         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24744         fac    = -expon * (c1 + evdwij) * rij_shift
24745         sigder = fac * sigder
24746 !          fac    = rij * fac
24747 ! Calculate distance derivative
24748         gg(1) =  fac
24749         gg(2) =  fac
24750         gg(3) =  fac
24751         fac = chis1 * sqom1 + chis2 * sqom2 &
24752         - 2.0d0 * chis12 * om1 * om2 * om12
24753 ! we will use pom later in Gcav, so dont mess with it!
24754         pom = 1.0d0 - chis1 * chis2 * sqom12
24755         Lambf = (1.0d0 - (fac / pom))
24756         Lambf = dsqrt(Lambf)
24757         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24758 !       write (*,*) "sparrow = ", sparrow
24759         Chif = 1.0d0/rij * sparrow
24760         ChiLambf = Chif * Lambf
24761         eagle = dsqrt(ChiLambf)
24762         bat = ChiLambf ** 11.0d0
24763         top = b1 * ( eagle + b2 * ChiLambf - b3 )
24764         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24765         botsq = bot * bot
24766         Fcav = top / bot
24767         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24768         dbot = 12.0d0 * b4 * bat * Lambf
24769         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24770 !       dFdR = 0.0d0
24771 !      write (*,*) "dFcav/dR = ", dFdR
24772         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24773         dbot = 12.0d0 * b4 * bat * Chif
24774         eagle = Lambf * pom
24775         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24776         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24777         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24778             * (chis2 * om2 * om12 - om1) / (eagle * pom)
24779
24780         dFdL = ((dtop * bot - top * dbot) / botsq)
24781 !       dFdL = 0.0d0
24782         dCAVdOM1  = dFdL * ( dFdOM1 )
24783         dCAVdOM2  = dFdL * ( dFdOM2 )
24784         dCAVdOM12 = dFdL * ( dFdOM12 )
24785
24786         ertail(1) = xj*rij
24787         ertail(2) = yj*rij
24788         ertail(3) = zj*rij
24789        DO k = 1, 3
24790 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24791 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24792 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
24793
24794       pom = ertail(k)
24795 !        print *,pom,gg(k),dFdR
24796 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24797       gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
24798               - (( dFdR + gg(k) ) * pom)
24799 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24800 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24801 !     &             - ( dFdR * pom )
24802 !        pom = ertail(k)
24803 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24804 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
24805 !                  + (( dFdR + gg(k) ) * pom)
24806 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24807 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24808 !c!     &             + ( dFdR * pom )
24809
24810       gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
24811               - (( dFdR + gg(k) ) * ertail(k))
24812 !c!     &             - ( dFdR * ertail(k))
24813
24814       gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
24815               + (( dFdR + gg(k) ) * ertail(k))/2.0
24816
24817       gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
24818               + (( dFdR + gg(k) ) * ertail(k))/2.0
24819
24820 !c!     &             + ( dFdR * ertail(k))
24821
24822       gg(k) = 0.0d0
24823       ENDDO
24824 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24825 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24826 !      alphapol1 = alphapol_scpho(itypi)
24827        if (wqq_scpho(itypi).ne.0.0) then
24828        Qij=wqq_scpho(itypi)/eps_in
24829        alpha_sco=1.d0/alphi_scpho(itypi)
24830 !       Qij=0.0
24831        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
24832 !c! derivative of Ecl is Gcl...
24833        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
24834             (Rhead*alpha_sco+1) ) / Rhead_sq
24835        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
24836        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
24837        w1        = wqdip_scpho(1,itypi)
24838        w2        = wqdip_scpho(2,itypi)
24839 !       w1=0.0d0
24840 !       w2=0.0d0
24841 !       pis       = sig0head_scbase(itypi,itypj)
24842 !       eps_head   = epshead_scbase(itypi,itypj)
24843 !c!-------------------------------------------------------------------
24844
24845 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24846 !c!     &        +dhead(1,1,itypi,itypj))**2))
24847 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24848 !c!     &        +dhead(2,1,itypi,itypj))**2))
24849
24850 !c!-------------------------------------------------------------------
24851 !c! ecl
24852        sparrow  = w1  *  om1
24853        hawk     = w2 *  (1.0d0 - sqom2)
24854        Ecl = sparrow / Rhead**2.0d0 &
24855          - hawk    / Rhead**4.0d0
24856 !c!-------------------------------------------------------------------
24857        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
24858          1.0/rij,sparrow
24859
24860 !c! derivative of ecl is Gcl
24861 !c! dF/dr part
24862        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
24863             + 4.0d0 * hawk    / Rhead**5.0d0
24864 !c! dF/dom1
24865        dGCLdOM1 = (w1) / (Rhead**2.0d0)
24866 !c! dF/dom2
24867        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
24868        endif
24869
24870 !c--------------------------------------------------------------------
24871 !c Polarization energy
24872 !c Epol
24873        R1 = 0.0d0
24874        DO k = 1, 3
24875 !c! Calculate head-to-tail distances tail is center of side-chain
24876       R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
24877        END DO
24878 !c! Pitagoras
24879        R1 = dsqrt(R1)
24880
24881       alphapol1 = alphapol_scpho(itypi)
24882 !      alphapol1=0.0
24883        MomoFac1 = (1.0d0 - chi2 * sqom1)
24884        RR1  = R1 * R1 / MomoFac1
24885        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24886 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
24887        fgb1 = sqrt( RR1 + a12sq * ee1)
24888 !       eps_inout_fac=0.0d0
24889        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
24890 ! derivative of Epol is Gpol...
24891        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
24892             / (fgb1 ** 5.0d0)
24893        dFGBdR1 = ( (R1 / MomoFac1) &
24894            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
24895            / ( 2.0d0 * fgb1 )
24896        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
24897              * (2.0d0 - 0.5d0 * ee1) ) &
24898              / (2.0d0 * fgb1)
24899        dPOLdR1 = dPOLdFGB1 * dFGBdR1
24900 !       dPOLdR1 = 0.0d0
24901 !       dPOLdOM1 = 0.0d0
24902        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
24903              * (2.0d0 - 0.5d0 * ee1) ) &
24904              / (2.0d0 * fgb1)
24905
24906        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
24907        dPOLdOM2 = 0.0
24908        DO k = 1, 3
24909       erhead(k) = Rhead_distance(k)/Rhead
24910       erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
24911        END DO
24912
24913        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24914        erdxj = scalar( erhead(1), dC_norm(1,j) )
24915        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
24916 !       bat=0.0d0
24917        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
24918        facd1 = d1i * vbld_inv(i+nres)
24919        facd2 = d1j * vbld_inv(j)
24920 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24921
24922        DO k = 1, 3
24923       hawk = (erhead_tail(k,1) + &
24924       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
24925 !        facd1=0.0d0
24926 !        facd2=0.0d0
24927 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
24928 !                pom,(erhead_tail(k,1))
24929
24930 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
24931       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24932       gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
24933                - dGCLdR * pom &
24934                - dPOLdR1 *  (erhead_tail(k,1))
24935 !     &             - dGLJdR * pom
24936
24937       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
24938 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
24939 !                   + dGCLdR * pom  &
24940 !                   + dPOLdR1 * (erhead_tail(k,1))
24941 !     &             + dGLJdR * pom
24942
24943
24944       gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
24945               - dGCLdR * erhead(k) &
24946               - dPOLdR1 * erhead_tail(k,1)
24947 !     &             - dGLJdR * erhead(k)
24948
24949       gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
24950               + (dGCLdR * erhead(k)  &
24951               + dPOLdR1 * erhead_tail(k,1))/2.0
24952       gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
24953               + (dGCLdR * erhead(k)  &
24954               + dPOLdR1 * erhead_tail(k,1))/2.0
24955
24956 !     &             + dGLJdR * erhead(k)
24957 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
24958
24959        END DO
24960 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
24961        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
24962       "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
24963        escpho=escpho+evdwij+epol+Fcav+ECL
24964        call sc_grad_scpho
24965        enddo
24966
24967       enddo
24968
24969       return
24970       end subroutine eprot_sc_phosphate
24971       SUBROUTINE sc_grad_scpho
24972       use calc_data
24973
24974        real (kind=8) :: dcosom1(3),dcosom2(3)
24975        eom1  =    &
24976             eps2der * eps2rt_om1   &
24977           - 2.0D0 * alf1 * eps3der &
24978           + sigder * sigsq_om1     &
24979           + dCAVdOM1               &
24980           + dGCLdOM1               &
24981           + dPOLdOM1
24982
24983        eom2  =  &
24984             eps2der * eps2rt_om2   &
24985           + 2.0D0 * alf2 * eps3der &
24986           + sigder * sigsq_om2     &
24987           + dCAVdOM2               &
24988           + dGCLdOM2               &
24989           + dPOLdOM2
24990
24991        eom12 =    &
24992             evdwij  * eps1_om12     &
24993           + eps2der * eps2rt_om12   &
24994           - 2.0D0 * alf12 * eps3der &
24995           + sigder *sigsq_om12      &
24996           + dCAVdOM12               &
24997           + dGCLdOM12
24998 !        om12=0.0
24999 !        eom12=0.0
25000 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
25001 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
25002 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
25003 !                 *dsci_inv*2.0
25004 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
25005 !               gg(1),gg(2),"rozne"
25006        DO k = 1, 3
25007       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25008       dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
25009       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25010       gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
25011              + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
25012              *dscj_inv*2.0 &
25013              - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25014       gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
25015              - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
25016              *dscj_inv*2.0 &
25017              + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25018       gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
25019              + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
25020              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25021
25022 !         print *,eom12,eom2,om12,om2
25023 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
25024 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
25025 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
25026 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
25027 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25028       gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
25029        END DO
25030        RETURN
25031       END SUBROUTINE sc_grad_scpho
25032       subroutine eprot_pep_phosphate(epeppho)
25033       use calc_data
25034 !      implicit real*8 (a-h,o-z)
25035 !      include 'DIMENSIONS'
25036 !      include 'COMMON.GEO'
25037 !      include 'COMMON.VAR'
25038 !      include 'COMMON.LOCAL'
25039 !      include 'COMMON.CHAIN'
25040 !      include 'COMMON.DERIV'
25041 !      include 'COMMON.NAMES'
25042 !      include 'COMMON.INTERACT'
25043 !      include 'COMMON.IOUNITS'
25044 !      include 'COMMON.CALC'
25045 !      include 'COMMON.CONTROL'
25046 !      include 'COMMON.SBRIDGE'
25047       logical :: lprn
25048 !el local variables
25049       integer :: iint,itypi,itypi1,itypj,subchap
25050       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
25051       real(kind=8) :: evdw,sig0ij
25052       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25053                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
25054                 sslipi,sslipj,faclip
25055       integer :: ii
25056       real(kind=8) :: fracinbuf
25057        real (kind=8) :: epeppho
25058        real (kind=8),dimension(4):: ener
25059        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
25060        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
25061       sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
25062       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
25063       dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
25064       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
25065       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
25066       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
25067        real(kind=8),dimension(3,2)::chead,erhead_tail
25068        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
25069        integer troll
25070        real (kind=8) :: dcosom1(3),dcosom2(3)
25071        epeppho=0.0d0
25072 !       do i=1,nres_molec(1)
25073       do i=ibond_start,ibond_end
25074       if (itype(i,1).eq.ntyp1_molec(1)) cycle
25075       itypi  = itype(i,1)
25076       dsci_inv = vbld_inv(i+1)/2.0
25077       dxi    = dc_norm(1,i)
25078       dyi    = dc_norm(2,i)
25079       dzi    = dc_norm(3,i)
25080       xi=(c(1,i)+c(1,i+1))/2.0
25081       yi=(c(2,i)+c(2,i+1))/2.0
25082       zi=(c(3,i)+c(3,i+1))/2.0
25083                call to_box(xi,yi,zi)
25084
25085         do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
25086          itypj= itype(j,2)
25087          if ((itype(j,2).eq.ntyp1_molec(2)).or.&
25088           (itype(j+1,2).eq.ntyp1_molec(2))) cycle
25089          xj=(c(1,j)+c(1,j+1))/2.0
25090          yj=(c(2,j)+c(2,j+1))/2.0
25091          zj=(c(3,j)+c(3,j+1))/2.0
25092                 call to_box(xj,yj,zj)
25093       xj=boxshift(xj-xi,boxxsize)
25094       yj=boxshift(yj-yi,boxysize)
25095       zj=boxshift(zj-zi,boxzsize)
25096
25097         dist_init=xj**2+yj**2+zj**2
25098         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25099         rij  = dsqrt(rrij)
25100         dxj = dc_norm( 1,j )
25101         dyj = dc_norm( 2,j )
25102         dzj = dc_norm( 3,j )
25103         dscj_inv = vbld_inv(j+1)/2.0
25104 ! Gay-berne var's
25105         sig0ij = sigma_peppho
25106 !          chi1=0.0d0
25107 !          chi2=0.0d0
25108         chi12  = chi1 * chi2
25109 !          chip1=0.0d0
25110 !          chip2=0.0d0
25111         chip12 = chip1 * chip2
25112 !          chis1 = 0.0d0
25113 !          chis2 = 0.0d0
25114         chis12 = chis1 * chis2
25115         sig1 = sigmap1_peppho
25116         sig2 = sigmap2_peppho
25117 !       write (*,*) "sig1 = ", sig1
25118 !       write (*,*) "sig1 = ", sig1
25119 !       write (*,*) "sig2 = ", sig2
25120 ! alpha factors from Fcav/Gcav
25121         alf1   = 0.0d0
25122         alf2   = 0.0d0
25123         alf12  = 0.0d0
25124         b1 = alphasur_peppho(1)
25125 !          b1=0.0d0
25126         b2 = alphasur_peppho(2)
25127         b3 = alphasur_peppho(3)
25128         b4 = alphasur_peppho(4)
25129         CALL sc_angular
25130        sqom1=om1*om1
25131        evdwij = 0.0d0
25132        ECL = 0.0d0
25133        Elj = 0.0d0
25134        Equad = 0.0d0
25135        Epol = 0.0d0
25136        Fcav=0.0d0
25137        eheadtail = 0.0d0
25138        dGCLdR=0.0d0
25139        dGCLdOM1 = 0.0d0
25140        dGCLdOM2 = 0.0d0
25141        dGCLdOM12 = 0.0d0
25142        dPOLdOM1 = 0.0d0
25143        dPOLdOM2 = 0.0d0
25144         Fcav = 0.0d0
25145         dFdR = 0.0d0
25146         dCAVdOM1  = 0.0d0
25147         dCAVdOM2  = 0.0d0
25148         dCAVdOM12 = 0.0d0
25149         rij_shift = rij
25150         fac       = rij_shift**expon
25151         c1        = fac  * fac * aa_peppho
25152 !          c1        = 0.0d0
25153         c2        = fac  * bb_peppho
25154 !          c2        = 0.0d0
25155         evdwij    =  c1 + c2
25156 ! Now cavity....................
25157        eagle = dsqrt(1.0/rij_shift)
25158        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
25159         bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
25160         botsq = bot * bot
25161         Fcav = top / bot
25162         dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
25163         dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
25164         dFdR = ((dtop * bot - top * dbot) / botsq)
25165        w1        = wqdip_peppho(1)
25166        w2        = wqdip_peppho(2)
25167 !       w1=0.0d0
25168 !       w2=0.0d0
25169 !       pis       = sig0head_scbase(itypi,itypj)
25170 !       eps_head   = epshead_scbase(itypi,itypj)
25171 !c!-------------------------------------------------------------------
25172
25173 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25174 !c!     &        +dhead(1,1,itypi,itypj))**2))
25175 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25176 !c!     &        +dhead(2,1,itypi,itypj))**2))
25177
25178 !c!-------------------------------------------------------------------
25179 !c! ecl
25180        sparrow  = w1  *  om1
25181        hawk     = w2 *  (1.0d0 - sqom1)
25182        Ecl = sparrow * rij_shift**2.0d0 &
25183          - hawk    * rij_shift**4.0d0
25184 !c!-------------------------------------------------------------------
25185 !c! derivative of ecl is Gcl
25186 !c! dF/dr part
25187 !       rij_shift=5.0
25188        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
25189             + 4.0d0 * hawk    * rij_shift**5.0d0
25190 !c! dF/dom1
25191        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
25192 !c! dF/dom2
25193        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
25194        eom1  =    dGCLdOM1+dGCLdOM2
25195        eom2  =    0.0
25196
25197         fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
25198 !          fac=0.0
25199         gg(1) =  fac*xj*rij
25200         gg(2) =  fac*yj*rij
25201         gg(3) =  fac*zj*rij
25202        do k=1,3
25203        gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
25204        gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
25205        gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
25206        gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
25207        gg(k)=0.0
25208        enddo
25209
25210       DO k = 1, 3
25211       dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
25212       dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
25213       gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
25214       gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
25215 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25216       gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
25217 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25218       gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
25219              - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25220       gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
25221              + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25222       enddo
25223        epeppho=epeppho+evdwij+Fcav+ECL
25224 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
25225        enddo
25226        enddo
25227       end subroutine eprot_pep_phosphate
25228 !!!!!!!!!!!!!!!!-------------------------------------------------------------
25229       subroutine emomo(evdw)
25230       use calc_data
25231       use comm_momo
25232 !      implicit real*8 (a-h,o-z)
25233 !      include 'DIMENSIONS'
25234 !      include 'COMMON.GEO'
25235 !      include 'COMMON.VAR'
25236 !      include 'COMMON.LOCAL'
25237 !      include 'COMMON.CHAIN'
25238 !      include 'COMMON.DERIV'
25239 !      include 'COMMON.NAMES'
25240 !      include 'COMMON.INTERACT'
25241 !      include 'COMMON.IOUNITS'
25242 !      include 'COMMON.CALC'
25243 !      include 'COMMON.CONTROL'
25244 !      include 'COMMON.SBRIDGE'
25245       logical :: lprn
25246 !el local variables
25247       integer :: iint,itypi1,subchap,isel
25248       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
25249       real(kind=8) :: evdw,aa,bb
25250       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25251                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
25252                 sslipi,sslipj,faclip,alpha_sco
25253       integer :: ii
25254       real(kind=8) :: fracinbuf
25255        real (kind=8) :: escpho
25256        real (kind=8),dimension(4):: ener
25257        real(kind=8) :: b1,b2,egb
25258        real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
25259       Lambf,&
25260       Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
25261       dFdOM2,dFdL,dFdOM12,&
25262       federmaus,&
25263       d1i,d1j
25264 !       real(kind=8),dimension(3,2)::erhead_tail
25265 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
25266        real(kind=8) ::  facd4, adler, Fgb, facd3
25267        integer troll,jj,istate
25268        real (kind=8) :: dcosom1(3),dcosom2(3)
25269        evdw=0.0d0
25270        eps_out=80.0d0
25271        sss_ele_cut=1.0d0
25272 !       print *,"EVDW KURW",evdw,nres
25273       do i=iatsc_s,iatsc_e
25274 !        print *,"I am in EVDW",i
25275       itypi=iabs(itype(i,1))
25276 !        if (i.ne.47) cycle
25277       if (itypi.eq.ntyp1) cycle
25278       itypi1=iabs(itype(i+1,1))
25279       xi=c(1,nres+i)
25280       yi=c(2,nres+i)
25281       zi=c(3,nres+i)
25282         call to_box(xi,yi,zi)
25283         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
25284 !       endif
25285 !       print *, sslipi,ssgradlipi
25286       dxi=dc_norm(1,nres+i)
25287       dyi=dc_norm(2,nres+i)
25288       dzi=dc_norm(3,nres+i)
25289 !        dsci_inv=dsc_inv(itypi)
25290       dsci_inv=vbld_inv(i+nres)
25291 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
25292 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
25293 !
25294 ! Calculate SC interaction energy.
25295 !
25296       do iint=1,nint_gr(i)
25297         do j=istart(i,iint),iend(i,iint)
25298 !             print *,"JA PIER",i,j,iint,istart(i,iint),iend(i,iint)
25299           IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
25300             call dyn_ssbond_ene(i,j,evdwij)
25301             evdw=evdw+evdwij
25302             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25303                         'evdw',i,j,evdwij,' ss'
25304 !              if (energy_dec) write (iout,*) &
25305 !                              'evdw',i,j,evdwij,' ss'
25306            do k=j+1,iend(i,iint)
25307 !C search over all next residues
25308             if (dyn_ss_mask(k)) then
25309 !C check if they are cysteins
25310 !C              write(iout,*) 'k=',k
25311
25312 !c              write(iout,*) "PRZED TRI", evdwij
25313 !               evdwij_przed_tri=evdwij
25314             call triple_ssbond_ene(i,j,k,evdwij)
25315 !c               if(evdwij_przed_tri.ne.evdwij) then
25316 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
25317 !c               endif
25318
25319 !c              write(iout,*) "PO TRI", evdwij
25320 !C call the energy function that removes the artifical triple disulfide
25321 !C bond the soubroutine is located in ssMD.F
25322             evdw=evdw+evdwij
25323             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
25324                       'evdw',i,j,evdwij,'tss'
25325             endif!dyn_ss_mask(k)
25326            enddo! k
25327           ELSE
25328 !el            ind=ind+1
25329           itypj=iabs(itype(j,1))
25330           if (itypj.eq.ntyp1) cycle
25331            CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
25332
25333 !             if (j.ne.78) cycle
25334 !            dscj_inv=dsc_inv(itypj)
25335           dscj_inv=vbld_inv(j+nres)
25336          xj=c(1,j+nres)
25337          yj=c(2,j+nres)
25338          zj=c(3,j+nres)
25339      call to_box(xj,yj,zj)
25340      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
25341 !      write(iout,*) "KRUWA", i,j
25342       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
25343       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
25344       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
25345       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
25346       xj=boxshift(xj-xi,boxxsize)
25347       yj=boxshift(yj-yi,boxysize)
25348       zj=boxshift(zj-zi,boxzsize)
25349         dxj = dc_norm( 1, nres+j )
25350         dyj = dc_norm( 2, nres+j )
25351         dzj = dc_norm( 3, nres+j )
25352 !          print *,i,j,itypi,itypj
25353 !          d1i=0.0d0
25354 !          d1j=0.0d0
25355 !          BetaT = 1.0d0 / (298.0d0 * Rb)
25356 ! Gay-berne var's
25357 !1!          sig0ij = sigma_scsc( itypi,itypj )
25358 !          chi1=0.0d0
25359 !          chi2=0.0d0
25360 !          chip1=0.0d0
25361 !          chip2=0.0d0
25362 ! not used by momo potential, but needed by sc_angular which is shared
25363 ! by all energy_potential subroutines
25364         alf1   = 0.0d0
25365         alf2   = 0.0d0
25366         alf12  = 0.0d0
25367         a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
25368 !       a12sq = a12sq * a12sq
25369 ! charge of amino acid itypi is...
25370         chis1 = chis(itypi,itypj)
25371         chis2 = chis(itypj,itypi)
25372         chis12 = chis1 * chis2
25373         sig1 = sigmap1(itypi,itypj)
25374         sig2 = sigmap2(itypi,itypj)
25375 !       write (*,*) "sig1 = ", sig1
25376 !          chis1=0.0
25377 !          chis2=0.0
25378 !                    chis12 = chis1 * chis2
25379 !          sig1=0.0
25380 !          sig2=0.0
25381 !       write (*,*) "sig2 = ", sig2
25382 ! alpha factors from Fcav/Gcav
25383         b1cav = alphasur(1,itypi,itypj)
25384 !          b1cav=0.0d0
25385         b2cav = alphasur(2,itypi,itypj)
25386         b3cav = alphasur(3,itypi,itypj)
25387         b4cav = alphasur(4,itypi,itypj)
25388 ! used to determine whether we want to do quadrupole calculations
25389        eps_in = epsintab(itypi,itypj)
25390        if (eps_in.eq.0.0) eps_in=1.0
25391
25392        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
25393        Rtail = 0.0d0
25394 !       dtail(1,itypi,itypj)=0.0
25395 !       dtail(2,itypi,itypj)=0.0
25396
25397        DO k = 1, 3
25398       ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
25399       ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
25400        END DO
25401 !c! tail distances will be themselves usefull elswhere
25402 !c1 (in Gcav, for example)
25403        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
25404        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
25405        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
25406        Rtail = dsqrt( &
25407         (Rtail_distance(1)*Rtail_distance(1)) &
25408       + (Rtail_distance(2)*Rtail_distance(2)) &
25409       + (Rtail_distance(3)*Rtail_distance(3)))
25410
25411 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
25412 !-------------------------------------------------------------------
25413 ! tail location and distance calculations
25414        d1 = dhead(1, 1, itypi, itypj)
25415        d2 = dhead(2, 1, itypi, itypj)
25416
25417        DO k = 1,3
25418 ! location of polar head is computed by taking hydrophobic centre
25419 ! and moving by a d1 * dc_norm vector
25420 ! see unres publications for very informative images
25421       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
25422       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
25423 ! distance
25424 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25425 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25426       Rhead_distance(k) = chead(k,2) - chead(k,1)
25427        END DO
25428 ! pitagoras (root of sum of squares)
25429        Rhead = dsqrt( &
25430         (Rhead_distance(1)*Rhead_distance(1)) &
25431       + (Rhead_distance(2)*Rhead_distance(2)) &
25432       + (Rhead_distance(3)*Rhead_distance(3)))
25433 !-------------------------------------------------------------------
25434 ! zero everything that should be zero'ed
25435        evdwij = 0.0d0
25436        ECL = 0.0d0
25437        Elj = 0.0d0
25438        Equad = 0.0d0
25439        Epol = 0.0d0
25440        Fcav=0.0d0
25441        eheadtail = 0.0d0
25442        dGCLdOM1 = 0.0d0
25443        dGCLdOM2 = 0.0d0
25444        dGCLdOM12 = 0.0d0
25445        dPOLdOM1 = 0.0d0
25446        dPOLdOM2 = 0.0d0
25447         Fcav = 0.0d0
25448         dFdR = 0.0d0
25449         dCAVdOM1  = 0.0d0
25450         dCAVdOM2  = 0.0d0
25451         dCAVdOM12 = 0.0d0
25452         dscj_inv = vbld_inv(j+nres)
25453 !          print *,i,j,dscj_inv,dsci_inv
25454 ! rij holds 1/(distance of Calpha atoms)
25455         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25456         rij  = dsqrt(rrij)
25457 !----------------------------
25458         CALL sc_angular
25459 ! this should be in elgrad_init but om's are calculated by sc_angular
25460 ! which in turn is used by older potentials
25461 ! om = omega, sqom = om^2
25462         sqom1  = om1 * om1
25463         sqom2  = om2 * om2
25464         sqom12 = om12 * om12
25465
25466 ! now we calculate EGB - Gey-Berne
25467 ! It will be summed up in evdwij and saved in evdw
25468         sigsq     = 1.0D0  / sigsq
25469         sig       = sig0ij * dsqrt(sigsq)
25470 !          rij_shift = 1.0D0  / rij - sig + sig0ij
25471         rij_shift = Rtail - sig + sig0ij
25472         IF (rij_shift.le.0.0D0) THEN
25473          evdw = 1.0D20
25474          RETURN
25475         END IF
25476         sigder = -sig * sigsq
25477         rij_shift = 1.0D0 / rij_shift
25478         fac       = rij_shift**expon
25479         c1        = fac  * fac * aa_aq(itypi,itypj)
25480 !          print *,"ADAM",aa_aq(itypi,itypj)
25481
25482 !          c1        = 0.0d0
25483         c2        = fac  * bb_aq(itypi,itypj)
25484 !          c2        = 0.0d0
25485         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
25486         eps2der   = eps3rt * evdwij
25487         eps3der   = eps2rt * evdwij
25488 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
25489         evdwij    = eps2rt * eps3rt * evdwij
25490 !#ifdef TSCSC
25491 !          IF (bb_aq(itypi,itypj).gt.0) THEN
25492 !           evdw_p = evdw_p + evdwij
25493 !          ELSE
25494 !           evdw_m = evdw_m + evdwij
25495 !          END IF
25496 !#else
25497         evdw = evdw  &
25498             + evdwij
25499 !#endif
25500
25501         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
25502         fac    = -expon * (c1 + evdwij) * rij_shift
25503         sigder = fac * sigder
25504 !          fac    = rij * fac
25505 ! Calculate distance derivative
25506         gg(1) =  fac
25507         gg(2) =  fac
25508         gg(3) =  fac
25509 !          if (b2.gt.0.0) then
25510         fac = chis1 * sqom1 + chis2 * sqom2 &
25511         - 2.0d0 * chis12 * om1 * om2 * om12
25512 ! we will use pom later in Gcav, so dont mess with it!
25513         pom = 1.0d0 - chis1 * chis2 * sqom12
25514         Lambf = (1.0d0 - (fac / pom))
25515 !          print *,"fac,pom",fac,pom,Lambf
25516         Lambf = dsqrt(Lambf)
25517         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
25518 !          print *,"sig1,sig2",sig1,sig2,itypi,itypj
25519 !       write (*,*) "sparrow = ", sparrow
25520         Chif = Rtail * sparrow
25521 !           print *,"rij,sparrow",rij , sparrow
25522         ChiLambf = Chif * Lambf
25523         eagle = dsqrt(ChiLambf)
25524         bat = ChiLambf ** 11.0d0
25525         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
25526         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
25527         botsq = bot * bot
25528 !          print *,top,bot,"bot,top",ChiLambf,Chif
25529         Fcav = top / bot
25530
25531        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
25532        dbot = 12.0d0 * b4cav * bat * Lambf
25533        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25534
25535         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
25536         dbot = 12.0d0 * b4cav * bat * Chif
25537         eagle = Lambf * pom
25538         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25539         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25540         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25541             * (chis2 * om2 * om12 - om1) / (eagle * pom)
25542
25543         dFdL = ((dtop * bot - top * dbot) / botsq)
25544 !       dFdL = 0.0d0
25545         dCAVdOM1  = dFdL * ( dFdOM1 )
25546         dCAVdOM2  = dFdL * ( dFdOM2 )
25547         dCAVdOM12 = dFdL * ( dFdOM12 )
25548
25549        DO k= 1, 3
25550       ertail(k) = Rtail_distance(k)/Rtail
25551        END DO
25552        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
25553        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
25554        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25555        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25556        DO k = 1, 3
25557 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25558 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25559       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25560       gvdwx(k,i) = gvdwx(k,i) &
25561               - (( dFdR + gg(k) ) * pom)
25562 !c!     &             - ( dFdR * pom )
25563       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25564       gvdwx(k,j) = gvdwx(k,j)   &
25565               + (( dFdR + gg(k) ) * pom)
25566 !c!     &             + ( dFdR * pom )
25567
25568       gvdwc(k,i) = gvdwc(k,i)  &
25569               - (( dFdR + gg(k) ) * ertail(k))
25570 !c!     &             - ( dFdR * ertail(k))
25571
25572       gvdwc(k,j) = gvdwc(k,j) &
25573               + (( dFdR + gg(k) ) * ertail(k))
25574 !c!     &             + ( dFdR * ertail(k))
25575
25576       gg(k) = 0.0d0
25577 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25578 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25579       END DO
25580
25581
25582 !c! Compute head-head and head-tail energies for each state
25583
25584         isel = iabs(Qi) + iabs(Qj)
25585 ! double charge for Phophorylated! itype - 25,27,27
25586 !          if ((itype(i).eq.27).or.(itype(i).eq.26).or.(itype(i).eq.25)) then
25587 !            Qi=Qi*2
25588 !            Qij=Qij*2
25589 !           endif
25590 !          if ((itype(j).eq.27).or.(itype(j).eq.26).or.(itype(j).eq.25)) then
25591 !            Qj=Qj*2
25592 !            Qij=Qij*2
25593 !           endif
25594
25595 !          isel=0
25596         IF (isel.eq.0) THEN
25597 !c! No charges - do nothing
25598          eheadtail = 0.0d0
25599
25600         ELSE IF (isel.eq.4) THEN
25601 !c! Calculate dipole-dipole interactions
25602          CALL edd(ecl)
25603          eheadtail = ECL
25604 !           eheadtail = 0.0d0
25605
25606         ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
25607 !c! Charge-nonpolar interactions
25608         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25609           Qi=Qi*2
25610           Qij=Qij*2
25611          endif
25612         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25613           Qj=Qj*2
25614           Qij=Qij*2
25615          endif
25616
25617          CALL eqn(epol)
25618          eheadtail = epol
25619 !           eheadtail = 0.0d0
25620
25621         ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
25622 !c! Nonpolar-charge interactions
25623         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25624           Qi=Qi*2
25625           Qij=Qij*2
25626          endif
25627         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25628           Qj=Qj*2
25629           Qij=Qij*2
25630          endif
25631
25632          CALL enq(epol)
25633          eheadtail = epol
25634 !           eheadtail = 0.0d0
25635
25636         ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
25637 !c! Charge-dipole interactions
25638         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25639           Qi=Qi*2
25640           Qij=Qij*2
25641          endif
25642         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25643           Qj=Qj*2
25644           Qij=Qij*2
25645          endif
25646
25647          CALL eqd(ecl, elj, epol)
25648          eheadtail = ECL + elj + epol
25649 !           eheadtail = 0.0d0
25650
25651         ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
25652 !c! Dipole-charge interactions
25653         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25654           Qi=Qi*2
25655           Qij=Qij*2
25656          endif
25657         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25658           Qj=Qj*2
25659           Qij=Qij*2
25660          endif
25661          CALL edq(ecl, elj, epol)
25662         eheadtail = ECL + elj + epol
25663 !           eheadtail = 0.0d0
25664
25665         ELSE IF ((isel.eq.2.and.   &
25666              iabs(Qi).eq.1).and.  &
25667              nstate(itypi,itypj).eq.1) THEN
25668 !c! Same charge-charge interaction ( +/+ or -/- )
25669         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25670           Qi=Qi*2
25671           Qij=Qij*2
25672          endif
25673         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25674           Qj=Qj*2
25675           Qij=Qij*2
25676          endif
25677
25678          CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
25679          eheadtail = ECL + Egb + Epol + Fisocav + Elj
25680 !           eheadtail = 0.0d0
25681
25682         ELSE IF ((isel.eq.2.and.  &
25683              iabs(Qi).eq.1).and. &
25684              nstate(itypi,itypj).ne.1) THEN
25685 !c! Different charge-charge interaction ( +/- or -/+ )
25686         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
25687           Qi=Qi*2
25688           Qij=Qij*2
25689          endif
25690         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
25691           Qj=Qj*2
25692           Qij=Qij*2
25693          endif
25694
25695          CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
25696         END IF
25697        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
25698       evdw = evdw  + Fcav + eheadtail
25699
25700        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
25701       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
25702       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
25703       Equad,evdwij+Fcav+eheadtail,evdw
25704 !       evdw = evdw  + Fcav  + eheadtail
25705
25706       iF (nstate(itypi,itypj).eq.1) THEN
25707       CALL sc_grad
25708        END IF
25709 !c!-------------------------------------------------------------------
25710 !c! NAPISY KONCOWE
25711        END DO   ! j
25712       END DO    ! iint
25713        END DO     ! i
25714 !c      write (iout,*) "Number of loop steps in EGB:",ind
25715 !c      energy_dec=.false.
25716 !              print *,"EVDW KURW",evdw,nres
25717
25718        RETURN
25719       END SUBROUTINE emomo
25720 !C------------------------------------------------------------------------------------
25721       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
25722       use calc_data
25723       use comm_momo
25724        real (kind=8) ::  facd3, facd4, federmaus, adler,&
25725        Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
25726 !       integer :: k
25727 !c! Epol and Gpol analytical parameters
25728        alphapol1 = alphapol(itypi,itypj)
25729        alphapol2 = alphapol(itypj,itypi)
25730 !c! Fisocav and Gisocav analytical parameters
25731        al1  = alphiso(1,itypi,itypj)
25732        al2  = alphiso(2,itypi,itypj)
25733        al3  = alphiso(3,itypi,itypj)
25734        al4  = alphiso(4,itypi,itypj)
25735        csig = (1.0d0  &
25736          / dsqrt(sigiso1(itypi, itypj)**2.0d0 &
25737          + sigiso2(itypi,itypj)**2.0d0))
25738 !c!
25739        pis  = sig0head(itypi,itypj)
25740        eps_head = epshead(itypi,itypj)
25741        Rhead_sq = Rhead * Rhead
25742 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25743 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25744        R1 = 0.0d0
25745        R2 = 0.0d0
25746        DO k = 1, 3
25747 !c! Calculate head-to-tail distances needed by Epol
25748       R1=R1+(ctail(k,2)-chead(k,1))**2
25749       R2=R2+(chead(k,2)-ctail(k,1))**2
25750        END DO
25751 !c! Pitagoras
25752        R1 = dsqrt(R1)
25753        R2 = dsqrt(R2)
25754
25755 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25756 !c!     &        +dhead(1,1,itypi,itypj))**2))
25757 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25758 !c!     &        +dhead(2,1,itypi,itypj))**2))
25759
25760 !c!-------------------------------------------------------------------
25761 !c! Coulomb electrostatic interaction
25762        Ecl = (332.0d0 * Qij) / Rhead
25763 !c! derivative of Ecl is Gcl...
25764        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
25765        dGCLdOM1 = 0.0d0
25766        dGCLdOM2 = 0.0d0
25767        dGCLdOM12 = 0.0d0
25768        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
25769        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
25770        debkap=debaykap(itypi,itypj)
25771        Egb = -(332.0d0 * Qij *&
25772       (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
25773 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
25774 !c! Derivative of Egb is Ggb...
25775        dGGBdFGB = -(-332.0d0 * Qij * &
25776        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
25777        -(332.0d0 * Qij *&
25778       (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
25779        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
25780        dGGBdR = dGGBdFGB * dFGBdR
25781 !c!-------------------------------------------------------------------
25782 !c! Fisocav - isotropic cavity creation term
25783 !c! or "how much energy it costs to put charged head in water"
25784        pom = Rhead * csig
25785        top = al1 * (dsqrt(pom) + al2 * pom - al3)
25786        bot = (1.0d0 + al4 * pom**12.0d0)
25787        botsq = bot * bot
25788        FisoCav = top / bot
25789 !      write (*,*) "Rhead = ",Rhead
25790 !      write (*,*) "csig = ",csig
25791 !      write (*,*) "pom = ",pom
25792 !      write (*,*) "al1 = ",al1
25793 !      write (*,*) "al2 = ",al2
25794 !      write (*,*) "al3 = ",al3
25795 !      write (*,*) "al4 = ",al4
25796 !        write (*,*) "top = ",top
25797 !        write (*,*) "bot = ",bot
25798 !c! Derivative of Fisocav is GCV...
25799        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
25800        dbot = 12.0d0 * al4 * pom ** 11.0d0
25801        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
25802 !c!-------------------------------------------------------------------
25803 !c! Epol
25804 !c! Polarization energy - charged heads polarize hydrophobic "neck"
25805        MomoFac1 = (1.0d0 - chi1 * sqom2)
25806        MomoFac2 = (1.0d0 - chi2 * sqom1)
25807        RR1  = ( R1 * R1 ) / MomoFac1
25808        RR2  = ( R2 * R2 ) / MomoFac2
25809        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25810        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
25811        fgb1 = sqrt( RR1 + a12sq * ee1 )
25812        fgb2 = sqrt( RR2 + a12sq * ee2 )
25813        epol = 332.0d0 * eps_inout_fac * ( &
25814       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
25815 !c!       epol = 0.0d0
25816        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
25817              / (fgb1 ** 5.0d0)
25818        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
25819              / (fgb2 ** 5.0d0)
25820        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
25821            / ( 2.0d0 * fgb1 )
25822        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
25823            / ( 2.0d0 * fgb2 )
25824        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
25825             * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
25826        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
25827             * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
25828        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25829 !c!       dPOLdR1 = 0.0d0
25830        dPOLdR2 = dPOLdFGB2 * dFGBdR2
25831 !c!       dPOLdR2 = 0.0d0
25832        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25833 !c!       dPOLdOM1 = 0.0d0
25834        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25835 !c!       dPOLdOM2 = 0.0d0
25836 !c!-------------------------------------------------------------------
25837 !c! Elj
25838 !c! Lennard-Jones 6-12 interaction between heads
25839        pom = (pis / Rhead)**6.0d0
25840        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25841 !c! derivative of Elj is Glj
25842        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
25843            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
25844 !c!-------------------------------------------------------------------
25845 !c! Return the results
25846 !c! These things do the dRdX derivatives, that is
25847 !c! allow us to change what we see from function that changes with
25848 !c! distance to function that changes with LOCATION (of the interaction
25849 !c! site)
25850        DO k = 1, 3
25851       erhead(k) = Rhead_distance(k)/Rhead
25852       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25853       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25854        END DO
25855
25856        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25857        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25858        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25859        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25860        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
25861        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25862        facd1 = d1 * vbld_inv(i+nres)
25863        facd2 = d2 * vbld_inv(j+nres)
25864        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25865        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25866
25867 !c! Now we add appropriate partial derivatives (one in each dimension)
25868        DO k = 1, 3
25869       hawk   = (erhead_tail(k,1) + &
25870       facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
25871       condor = (erhead_tail(k,2) + &
25872       facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
25873
25874       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25875       gvdwx(k,i) = gvdwx(k,i) &
25876               - dGCLdR * pom&
25877               - dGGBdR * pom&
25878               - dGCVdR * pom&
25879               - dPOLdR1 * hawk&
25880               - dPOLdR2 * (erhead_tail(k,2)&
25881       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
25882               - dGLJdR * pom
25883
25884       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25885       gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom&
25886                + dGGBdR * pom+ dGCVdR * pom&
25887               + dPOLdR1 * (erhead_tail(k,1)&
25888       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))&
25889               + dPOLdR2 * condor + dGLJdR * pom
25890
25891       gvdwc(k,i) = gvdwc(k,i)  &
25892               - dGCLdR * erhead(k)&
25893               - dGGBdR * erhead(k)&
25894               - dGCVdR * erhead(k)&
25895               - dPOLdR1 * erhead_tail(k,1)&
25896               - dPOLdR2 * erhead_tail(k,2)&
25897               - dGLJdR * erhead(k)
25898
25899       gvdwc(k,j) = gvdwc(k,j)         &
25900               + dGCLdR * erhead(k) &
25901               + dGGBdR * erhead(k) &
25902               + dGCVdR * erhead(k) &
25903               + dPOLdR1 * erhead_tail(k,1) &
25904               + dPOLdR2 * erhead_tail(k,2)&
25905               + dGLJdR * erhead(k)
25906
25907        END DO
25908        RETURN
25909       END SUBROUTINE eqq
25910
25911       SUBROUTINE eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
25912       use calc_data
25913       use comm_momo
25914        real (kind=8) ::  facd3, facd4, federmaus, adler,&
25915        Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
25916 !       integer :: k
25917 !c! Epol and Gpol analytical parameters
25918        alphapol1 = alphapolcat(itypi,itypj)
25919        alphapol2 = alphapolcat(itypj,itypi)
25920 !c! Fisocav and Gisocav analytical parameters
25921        al1  = alphisocat(1,itypi,itypj)
25922        al2  = alphisocat(2,itypi,itypj)
25923        al3  = alphisocat(3,itypi,itypj)
25924        al4  = alphisocat(4,itypi,itypj)
25925        csig = (1.0d0  &
25926          / dsqrt(sigiso1cat(itypi, itypj)**2.0d0 &
25927          + sigiso2cat(itypi,itypj)**2.0d0))
25928 !c!
25929        pis  = sig0headcat(itypi,itypj)
25930        eps_head = epsheadcat(itypi,itypj)
25931        Rhead_sq = Rhead * Rhead
25932 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25933 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25934        R1 = 0.0d0
25935        R2 = 0.0d0
25936        DO k = 1, 3
25937 !c! Calculate head-to-tail distances needed by Epol
25938       R1=R1+(ctail(k,2)-chead(k,1))**2
25939       R2=R2+(chead(k,2)-ctail(k,1))**2
25940        END DO
25941 !c! Pitagoras
25942        R1 = dsqrt(R1)
25943        R2 = dsqrt(R2)
25944
25945 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25946 !c!     &        +dhead(1,1,itypi,itypj))**2))
25947 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25948 !c!     &        +dhead(2,1,itypi,itypj))**2))
25949
25950 !c!-------------------------------------------------------------------
25951 !c! Coulomb electrostatic interaction
25952        Ecl = (332.0d0 * Qij) / Rhead
25953 !c! derivative of Ecl is Gcl...
25954        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
25955        dGCLdOM1 = 0.0d0
25956        dGCLdOM2 = 0.0d0
25957        dGCLdOM12 = 0.0d0
25958        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
25959        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
25960        debkap=debaykapcat(itypi,itypj)
25961        Egb = -(332.0d0 * Qij *&
25962       (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
25963 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
25964 !c! Derivative of Egb is Ggb...
25965        dGGBdFGB = -(-332.0d0 * Qij * &
25966        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
25967        -(332.0d0 * Qij *&
25968       (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
25969        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
25970        dGGBdR = dGGBdFGB * dFGBdR
25971 !c!-------------------------------------------------------------------
25972 !c! Fisocav - isotropic cavity creation term
25973 !c! or "how much energy it costs to put charged head in water"
25974        pom = Rhead * csig
25975        top = al1 * (dsqrt(pom) + al2 * pom - al3)
25976        bot = (1.0d0 + al4 * pom**12.0d0)
25977        botsq = bot * bot
25978        FisoCav = top / bot
25979 !      write (*,*) "Rhead = ",Rhead
25980 !      write (*,*) "csig = ",csig
25981 !      write (*,*) "pom = ",pom
25982 !      write (*,*) "al1 = ",al1
25983 !      write (*,*) "al2 = ",al2
25984 !      write (*,*) "al3 = ",al3
25985 !      write (*,*) "al4 = ",al4
25986 !        write (*,*) "top = ",top
25987 !        write (*,*) "bot = ",bot
25988 !c! Derivative of Fisocav is GCV...
25989        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
25990        dbot = 12.0d0 * al4 * pom ** 11.0d0
25991        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
25992 !c!-------------------------------------------------------------------
25993 !c! Epol
25994 !c! Polarization energy - charged heads polarize hydrophobic "neck"
25995        MomoFac1 = (1.0d0 - chi1 * sqom2)
25996        MomoFac2 = (1.0d0 - chi2 * sqom1)
25997        RR1  = ( R1 * R1 ) / MomoFac1
25998        RR2  = ( R2 * R2 ) / MomoFac2
25999        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26000        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26001        fgb1 = sqrt( RR1 + a12sq * ee1 )
26002        fgb2 = sqrt( RR2 + a12sq * ee2 )
26003        epol = 332.0d0 * eps_inout_fac * ( &
26004       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26005 !c!       epol = 0.0d0
26006        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26007              / (fgb1 ** 5.0d0)
26008        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26009              / (fgb2 ** 5.0d0)
26010        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
26011            / ( 2.0d0 * fgb1 )
26012        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
26013            / ( 2.0d0 * fgb2 )
26014        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
26015             * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
26016        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
26017             * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
26018        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26019 !c!       dPOLdR1 = 0.0d0
26020        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26021 !c!       dPOLdR2 = 0.0d0
26022        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26023 !c!       dPOLdOM1 = 0.0d0
26024        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26025 !c!       dPOLdOM2 = 0.0d0
26026 !c!-------------------------------------------------------------------
26027 !c! Elj
26028 !c! Lennard-Jones 6-12 interaction between heads
26029        pom = (pis / Rhead)**6.0d0
26030        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26031 !c! derivative of Elj is Glj
26032        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
26033            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26034 !c!-------------------------------------------------------------------
26035 !c! Return the results
26036 !c! These things do the dRdX derivatives, that is
26037 !c! allow us to change what we see from function that changes with
26038 !c! distance to function that changes with LOCATION (of the interaction
26039 !c! site)
26040        DO k = 1, 3
26041       erhead(k) = Rhead_distance(k)/Rhead
26042       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26043       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26044        END DO
26045
26046        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26047        erdxj = scalar( erhead(1), dC_norm(1,j) )
26048        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26049        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
26050        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
26051        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26052        facd1 = d1 * vbld_inv(i+nres)
26053        facd2 = d2 * vbld_inv(j)
26054        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
26055        facd4 = dtailcat(2,itypi,itypj) * vbld_inv(j)
26056
26057 !c! Now we add appropriate partial derivatives (one in each dimension)
26058        DO k = 1, 3
26059       hawk   = (erhead_tail(k,1) + &
26060       facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
26061       condor = (erhead_tail(k,2) + &
26062       facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
26063
26064       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26065       gradpepcatx(k,i) = gradpepcatx(k,i) &
26066               - dGCLdR * pom&
26067               - dGGBdR * pom&
26068               - dGCVdR * pom&
26069               - dPOLdR1 * hawk&
26070               - dPOLdR2 * (erhead_tail(k,2)&
26071       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26072               - dGLJdR * pom
26073
26074       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
26075 !        gradpepcatx(k,j) = gradpepcatx(k,j)+ dGCLdR * pom&
26076 !                   + dGGBdR * pom+ dGCVdR * pom&
26077 !                  + dPOLdR1 * (erhead_tail(k,1)&
26078 !      -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j)))&
26079 !                  + dPOLdR2 * condor + dGLJdR * pom
26080
26081       gradpepcat(k,i) = gradpepcat(k,i)  &
26082               - dGCLdR * erhead(k)&
26083               - dGGBdR * erhead(k)&
26084               - dGCVdR * erhead(k)&
26085               - dPOLdR1 * erhead_tail(k,1)&
26086               - dPOLdR2 * erhead_tail(k,2)&
26087               - dGLJdR * erhead(k)
26088
26089       gradpepcat(k,j) = gradpepcat(k,j)         &
26090               + dGCLdR * erhead(k) &
26091               + dGGBdR * erhead(k) &
26092               + dGCVdR * erhead(k) &
26093               + dPOLdR1 * erhead_tail(k,1) &
26094               + dPOLdR2 * erhead_tail(k,2)&
26095               + dGLJdR * erhead(k)
26096
26097        END DO
26098        RETURN
26099       END SUBROUTINE eqq_cat
26100 !c!-------------------------------------------------------------------
26101       SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
26102       use comm_momo
26103       use calc_data
26104
26105        double precision eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad
26106        double precision ener(4)
26107        double precision dcosom1(3),dcosom2(3)
26108 !c! used in Epol derivatives
26109        double precision facd3, facd4
26110        double precision federmaus, adler
26111        integer istate,ii,jj
26112        real (kind=8) :: Fgb
26113 !       print *,"CALLING EQUAD"
26114 !c! Epol and Gpol analytical parameters
26115        alphapol1 = alphapol(itypi,itypj)
26116        alphapol2 = alphapol(itypj,itypi)
26117 !c! Fisocav and Gisocav analytical parameters
26118        al1  = alphiso(1,itypi,itypj)
26119        al2  = alphiso(2,itypi,itypj)
26120        al3  = alphiso(3,itypi,itypj)
26121        al4  = alphiso(4,itypi,itypj)
26122        csig = (1.0d0 / dsqrt(sigiso1(itypi, itypj)**2.0d0&
26123           + sigiso2(itypi,itypj)**2.0d0))
26124 !c!
26125        w1   = wqdip(1,itypi,itypj)
26126        w2   = wqdip(2,itypi,itypj)
26127        pis  = sig0head(itypi,itypj)
26128        eps_head = epshead(itypi,itypj)
26129 !c! First things first:
26130 !c! We need to do sc_grad's job with GB and Fcav
26131        eom1  = eps2der * eps2rt_om1 &
26132            - 2.0D0 * alf1 * eps3der&
26133            + sigder * sigsq_om1&
26134            + dCAVdOM1
26135        eom2  = eps2der * eps2rt_om2 &
26136            + 2.0D0 * alf2 * eps3der&
26137            + sigder * sigsq_om2&
26138            + dCAVdOM2
26139        eom12 =  evdwij  * eps1_om12 &
26140            + eps2der * eps2rt_om12 &
26141            - 2.0D0 * alf12 * eps3der&
26142            + sigder *sigsq_om12&
26143            + dCAVdOM12
26144 !c! now some magical transformations to project gradient into
26145 !c! three cartesian vectors
26146        DO k = 1, 3
26147       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
26148       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
26149       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
26150 !c! this acts on hydrophobic center of interaction
26151       gvdwx(k,i)= gvdwx(k,i) - gg(k) &
26152               + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
26153               + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26154       gvdwx(k,j)= gvdwx(k,j) + gg(k) &
26155               + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))&
26156               + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26157 !c! this acts on Calpha
26158       gvdwc(k,i)=gvdwc(k,i)-gg(k)
26159       gvdwc(k,j)=gvdwc(k,j)+gg(k)
26160        END DO
26161 !c! sc_grad is done, now we will compute
26162        eheadtail = 0.0d0
26163        eom1 = 0.0d0
26164        eom2 = 0.0d0
26165        eom12 = 0.0d0
26166        DO istate = 1, nstate(itypi,itypj)
26167 !c*************************************************************
26168       IF (istate.ne.1) THEN
26169        IF (istate.lt.3) THEN
26170         ii = 1
26171        ELSE
26172         ii = 2
26173        END IF
26174       jj = istate/ii
26175       d1 = dhead(1,ii,itypi,itypj)
26176       d2 = dhead(2,jj,itypi,itypj)
26177       DO k = 1,3
26178        chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
26179        chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
26180        Rhead_distance(k) = chead(k,2) - chead(k,1)
26181       END DO
26182 !c! pitagoras (root of sum of squares)
26183       Rhead = dsqrt( &
26184              (Rhead_distance(1)*Rhead_distance(1))  &
26185            + (Rhead_distance(2)*Rhead_distance(2))  &
26186            + (Rhead_distance(3)*Rhead_distance(3)))
26187       END IF
26188       Rhead_sq = Rhead * Rhead
26189
26190 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26191 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26192       R1 = 0.0d0
26193       R2 = 0.0d0
26194       DO k = 1, 3
26195 !c! Calculate head-to-tail distances
26196        R1=R1+(ctail(k,2)-chead(k,1))**2
26197        R2=R2+(chead(k,2)-ctail(k,1))**2
26198       END DO
26199 !c! Pitagoras
26200       R1 = dsqrt(R1)
26201       R2 = dsqrt(R2)
26202       Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
26203 !c!        Ecl = 0.0d0
26204 !c!        write (*,*) "Ecl = ", Ecl
26205 !c! derivative of Ecl is Gcl...
26206       dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
26207 !c!        dGCLdR = 0.0d0
26208       dGCLdOM1 = 0.0d0
26209       dGCLdOM2 = 0.0d0
26210       dGCLdOM12 = 0.0d0
26211 !c!-------------------------------------------------------------------
26212 !c! Generalised Born Solvent Polarization
26213       ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26214       Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26215       Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
26216 !c!        Egb = 0.0d0
26217 !c!      write (*,*) "a1*a2 = ", a12sq
26218 !c!      write (*,*) "Rhead = ", Rhead
26219 !c!      write (*,*) "Rhead_sq = ", Rhead_sq
26220 !c!      write (*,*) "ee = ", ee
26221 !c!      write (*,*) "Fgb = ", Fgb
26222 !c!      write (*,*) "fac = ", eps_inout_fac
26223 !c!      write (*,*) "Qij = ", Qij
26224 !c!      write (*,*) "Egb = ", Egb
26225 !c! Derivative of Egb is Ggb...
26226 !c! dFGBdR is used by Quad's later...
26227       dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
26228       dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )&
26229              / ( 2.0d0 * Fgb )
26230       dGGBdR = dGGBdFGB * dFGBdR
26231 !c!        dGGBdR = 0.0d0
26232 !c!-------------------------------------------------------------------
26233 !c! Fisocav - isotropic cavity creation term
26234       pom = Rhead * csig
26235       top = al1 * (dsqrt(pom) + al2 * pom - al3)
26236       bot = (1.0d0 + al4 * pom**12.0d0)
26237       botsq = bot * bot
26238       FisoCav = top / bot
26239       dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26240       dbot = 12.0d0 * al4 * pom ** 11.0d0
26241       dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26242 !c!        dGCVdR = 0.0d0
26243 !c!-------------------------------------------------------------------
26244 !c! Polarization energy
26245 !c! Epol
26246       MomoFac1 = (1.0d0 - chi1 * sqom2)
26247       MomoFac2 = (1.0d0 - chi2 * sqom1)
26248       RR1  = ( R1 * R1 ) / MomoFac1
26249       RR2  = ( R2 * R2 ) / MomoFac2
26250       ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26251       ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26252       fgb1 = sqrt( RR1 + a12sq * ee1 )
26253       fgb2 = sqrt( RR2 + a12sq * ee2 )
26254       epol = 332.0d0 * eps_inout_fac * (&
26255       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26256 !c!        epol = 0.0d0
26257 !c! derivative of Epol is Gpol...
26258       dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26259               / (fgb1 ** 5.0d0)
26260       dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26261               / (fgb2 ** 5.0d0)
26262       dFGBdR1 = ( (R1 / MomoFac1) &
26263             * ( 2.0d0 - (0.5d0 * ee1) ) )&
26264             / ( 2.0d0 * fgb1 )
26265       dFGBdR2 = ( (R2 / MomoFac2) &
26266             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26267             / ( 2.0d0 * fgb2 )
26268       dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26269              * ( 2.0d0 - 0.5d0 * ee1) ) &
26270              / ( 2.0d0 * fgb1 )
26271       dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26272              * ( 2.0d0 - 0.5d0 * ee2) ) &
26273              / ( 2.0d0 * fgb2 )
26274       dPOLdR1 = dPOLdFGB1 * dFGBdR1
26275 !c!        dPOLdR1 = 0.0d0
26276       dPOLdR2 = dPOLdFGB2 * dFGBdR2
26277 !c!        dPOLdR2 = 0.0d0
26278       dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26279 !c!        dPOLdOM1 = 0.0d0
26280       dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26281       pom = (pis / Rhead)**6.0d0
26282       Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26283 !c!        Elj = 0.0d0
26284 !c! derivative of Elj is Glj
26285       dGLJdR = 4.0d0 * eps_head &
26286           * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26287           +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26288 !c!        dGLJdR = 0.0d0
26289 !c!-------------------------------------------------------------------
26290 !c! Equad
26291        IF (Wqd.ne.0.0d0) THEN
26292       Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) &
26293            - 37.5d0  * ( sqom1 + sqom2 ) &
26294            + 157.5d0 * ( sqom1 * sqom2 ) &
26295            - 45.0d0  * om1*om2*om12
26296       fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
26297       Equad = fac * Beta1
26298 !c!        Equad = 0.0d0
26299 !c! derivative of Equad...
26300       dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
26301 !c!        dQUADdR = 0.0d0
26302       dQUADdOM1 = fac* (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
26303 !c!        dQUADdOM1 = 0.0d0
26304       dQUADdOM2 = fac* (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
26305 !c!        dQUADdOM2 = 0.0d0
26306       dQUADdOM12 = fac * ( 6.0d0*om12 - 45.0d0*om1*om2 )
26307        ELSE
26308        Beta1 = 0.0d0
26309        Equad = 0.0d0
26310       END IF
26311 !c!-------------------------------------------------------------------
26312 !c! Return the results
26313 !c! Angular stuff
26314       eom1 = dPOLdOM1 + dQUADdOM1
26315       eom2 = dPOLdOM2 + dQUADdOM2
26316       eom12 = dQUADdOM12
26317 !c! now some magical transformations to project gradient into
26318 !c! three cartesian vectors
26319       DO k = 1, 3
26320        dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
26321        dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
26322        tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
26323       END DO
26324 !c! Radial stuff
26325       DO k = 1, 3
26326        erhead(k) = Rhead_distance(k)/Rhead
26327        erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26328        erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26329       END DO
26330       erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26331       erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26332       bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26333       federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26334       eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26335       adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26336       facd1 = d1 * vbld_inv(i+nres)
26337       facd2 = d2 * vbld_inv(j+nres)
26338       facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26339       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26340       DO k = 1, 3
26341        hawk   = erhead_tail(k,1) + &
26342        facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
26343        condor = erhead_tail(k,2) + &
26344        facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
26345
26346        pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26347 !c! this acts on hydrophobic center of interaction
26348        gheadtail(k,1,1) = gheadtail(k,1,1) &
26349                    - dGCLdR * pom &
26350                    - dGGBdR * pom &
26351                    - dGCVdR * pom &
26352                    - dPOLdR1 * hawk &
26353                    - dPOLdR2 * (erhead_tail(k,2) &
26354       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26355                    - dGLJdR * pom &
26356                    - dQUADdR * pom&
26357                    - tuna(k) &
26358              + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
26359              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26360
26361        pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26362 !c! this acts on hydrophobic center of interaction
26363        gheadtail(k,2,1) = gheadtail(k,2,1)  &
26364                    + dGCLdR * pom      &
26365                    + dGGBdR * pom      &
26366                    + dGCVdR * pom      &
26367                    + dPOLdR1 * (erhead_tail(k,1) &
26368       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
26369                    + dPOLdR2 * condor &
26370                    + dGLJdR * pom &
26371                    + dQUADdR * pom &
26372                    + tuna(k) &
26373              + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
26374              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26375
26376 !c! this acts on Calpha
26377        gheadtail(k,3,1) = gheadtail(k,3,1)  &
26378                    - dGCLdR * erhead(k)&
26379                    - dGGBdR * erhead(k)&
26380                    - dGCVdR * erhead(k)&
26381                    - dPOLdR1 * erhead_tail(k,1)&
26382                    - dPOLdR2 * erhead_tail(k,2)&
26383                    - dGLJdR * erhead(k) &
26384                    - dQUADdR * erhead(k)&
26385                    - tuna(k)
26386 !c! this acts on Calpha
26387        gheadtail(k,4,1) = gheadtail(k,4,1)   &
26388                     + dGCLdR * erhead(k) &
26389                     + dGGBdR * erhead(k) &
26390                     + dGCVdR * erhead(k) &
26391                     + dPOLdR1 * erhead_tail(k,1) &
26392                     + dPOLdR2 * erhead_tail(k,2) &
26393                     + dGLJdR * erhead(k) &
26394                     + dQUADdR * erhead(k)&
26395                     + tuna(k)
26396       END DO
26397       ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
26398       eheadtail = eheadtail &
26399               + wstate(istate, itypi, itypj) &
26400               * dexp(-betaT * ener(istate))
26401 !c! foreach cartesian dimension
26402       DO k = 1, 3
26403 !c! foreach of two gvdwx and gvdwc
26404        DO l = 1, 4
26405         gheadtail(k,l,2) = gheadtail(k,l,2)  &
26406                      + wstate( istate, itypi, itypj ) &
26407                      * dexp(-betaT * ener(istate)) &
26408                      * gheadtail(k,l,1)
26409         gheadtail(k,l,1) = 0.0d0
26410        END DO
26411       END DO
26412        END DO
26413 !c! Here ended the gigantic DO istate = 1, 4, which starts
26414 !c! at the beggining of the subroutine
26415
26416        DO k = 1, 3
26417       DO l = 1, 4
26418        gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
26419       END DO
26420       gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
26421       gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
26422       gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
26423       gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
26424       DO l = 1, 4
26425        gheadtail(k,l,1) = 0.0d0
26426        gheadtail(k,l,2) = 0.0d0
26427       END DO
26428        END DO
26429        eheadtail = (-dlog(eheadtail)) / betaT
26430        dPOLdOM1 = 0.0d0
26431        dPOLdOM2 = 0.0d0
26432        dQUADdOM1 = 0.0d0
26433        dQUADdOM2 = 0.0d0
26434        dQUADdOM12 = 0.0d0
26435        RETURN
26436       END SUBROUTINE energy_quad
26437 !!-----------------------------------------------------------
26438       SUBROUTINE eqn(Epol)
26439       use comm_momo
26440       use calc_data
26441
26442       double precision  facd4, federmaus,epol
26443       alphapol1 = alphapol(itypi,itypj)
26444 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26445        R1 = 0.0d0
26446        DO k = 1, 3
26447 !c! Calculate head-to-tail distances
26448       R1=R1+(ctail(k,2)-chead(k,1))**2
26449        END DO
26450 !c! Pitagoras
26451        R1 = dsqrt(R1)
26452
26453 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26454 !c!     &        +dhead(1,1,itypi,itypj))**2))
26455 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26456 !c!     &        +dhead(2,1,itypi,itypj))**2))
26457 !c--------------------------------------------------------------------
26458 !c Polarization energy
26459 !c Epol
26460        MomoFac1 = (1.0d0 - chi1 * sqom2)
26461        RR1  = R1 * R1 / MomoFac1
26462        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26463        fgb1 = sqrt( RR1 + a12sq * ee1)
26464        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26465        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26466              / (fgb1 ** 5.0d0)
26467        dFGBdR1 = ( (R1 / MomoFac1) &
26468             * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26469             / ( 2.0d0 * fgb1 )
26470        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26471             * (2.0d0 - 0.5d0 * ee1) ) &
26472             / (2.0d0 * fgb1)
26473        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26474 !c!       dPOLdR1 = 0.0d0
26475        dPOLdOM1 = 0.0d0
26476        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26477        DO k = 1, 3
26478       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26479        END DO
26480        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26481        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26482        facd1 = d1 * vbld_inv(i+nres)
26483        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26484
26485        DO k = 1, 3
26486       hawk = (erhead_tail(k,1) + &
26487       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26488
26489       gvdwx(k,i) = gvdwx(k,i) &
26490                - dPOLdR1 * hawk
26491       gvdwx(k,j) = gvdwx(k,j) &
26492                + dPOLdR1 * (erhead_tail(k,1) &
26493        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
26494
26495       gvdwc(k,i) = gvdwc(k,i)  - dPOLdR1 * erhead_tail(k,1)
26496       gvdwc(k,j) = gvdwc(k,j)  + dPOLdR1 * erhead_tail(k,1)
26497
26498        END DO
26499        RETURN
26500       END SUBROUTINE eqn
26501       SUBROUTINE enq(Epol)
26502       use calc_data
26503       use comm_momo
26504        double precision facd3, adler,epol
26505        alphapol2 = alphapol(itypj,itypi)
26506 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26507        R2 = 0.0d0
26508        DO k = 1, 3
26509 !c! Calculate head-to-tail distances
26510       R2=R2+(chead(k,2)-ctail(k,1))**2
26511        END DO
26512 !c! Pitagoras
26513        R2 = dsqrt(R2)
26514
26515 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26516 !c!     &        +dhead(1,1,itypi,itypj))**2))
26517 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26518 !c!     &        +dhead(2,1,itypi,itypj))**2))
26519 !c------------------------------------------------------------------------
26520 !c Polarization energy
26521        MomoFac2 = (1.0d0 - chi2 * sqom1)
26522        RR2  = R2 * R2 / MomoFac2
26523        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26524        fgb2 = sqrt(RR2  + a12sq * ee2)
26525        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26526        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26527             / (fgb2 ** 5.0d0)
26528        dFGBdR2 = ( (R2 / MomoFac2)  &
26529             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26530             / (2.0d0 * fgb2)
26531        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26532             * (2.0d0 - 0.5d0 * ee2) ) &
26533             / (2.0d0 * fgb2)
26534        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26535 !c!       dPOLdR2 = 0.0d0
26536        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26537 !c!       dPOLdOM1 = 0.0d0
26538        dPOLdOM2 = 0.0d0
26539 !c!-------------------------------------------------------------------
26540 !c! Return the results
26541 !c! (See comments in Eqq)
26542        DO k = 1, 3
26543       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26544        END DO
26545        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26546        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26547        facd2 = d2 * vbld_inv(j+nres)
26548        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26549        DO k = 1, 3
26550       condor = (erhead_tail(k,2) &
26551        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26552
26553       gvdwx(k,i) = gvdwx(k,i) &
26554                - dPOLdR2 * (erhead_tail(k,2) &
26555        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
26556       gvdwx(k,j) = gvdwx(k,j)   &
26557                + dPOLdR2 * condor
26558
26559       gvdwc(k,i) = gvdwc(k,i) &
26560                - dPOLdR2 * erhead_tail(k,2)
26561       gvdwc(k,j) = gvdwc(k,j) &
26562                + dPOLdR2 * erhead_tail(k,2)
26563
26564        END DO
26565       RETURN
26566       END SUBROUTINE enq
26567
26568       SUBROUTINE enq_cat(Epol)
26569       use calc_data
26570       use comm_momo
26571        double precision facd3, adler,epol
26572        alphapol2 = alphapolcat(itypj,itypi)
26573 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26574        R2 = 0.0d0
26575        DO k = 1, 3
26576 !c! Calculate head-to-tail distances
26577       R2=R2+(chead(k,2)-ctail(k,1))**2
26578        END DO
26579 !c! Pitagoras
26580        R2 = dsqrt(R2)
26581
26582 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26583 !c!     &        +dhead(1,1,itypi,itypj))**2))
26584 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26585 !c!     &        +dhead(2,1,itypi,itypj))**2))
26586 !c------------------------------------------------------------------------
26587 !c Polarization energy
26588        MomoFac2 = (1.0d0 - chi2 * sqom1)
26589        RR2  = R2 * R2 / MomoFac2
26590        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26591        fgb2 = sqrt(RR2  + a12sq * ee2)
26592        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26593        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26594             / (fgb2 ** 5.0d0)
26595        dFGBdR2 = ( (R2 / MomoFac2)  &
26596             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26597             / (2.0d0 * fgb2)
26598        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26599             * (2.0d0 - 0.5d0 * ee2) ) &
26600             / (2.0d0 * fgb2)
26601        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26602 !c!       dPOLdR2 = 0.0d0
26603        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26604 !c!       dPOLdOM1 = 0.0d0
26605        dPOLdOM2 = 0.0d0
26606
26607 !c!-------------------------------------------------------------------
26608 !c! Return the results
26609 !c! (See comments in Eqq)
26610        DO k = 1, 3
26611       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26612        END DO
26613        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
26614        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26615        facd2 = d2 * vbld_inv(j+nres)
26616        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
26617        DO k = 1, 3
26618       condor = (erhead_tail(k,2) &
26619        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
26620
26621       gradpepcatx(k,i) = gradpepcatx(k,i) &
26622                - dPOLdR2 * (erhead_tail(k,2) &
26623        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
26624 !        gradpepcatx(k,j) = gradpepcatx(k,j)   &
26625 !                   + dPOLdR2 * condor
26626
26627       gradpepcat(k,i) = gradpepcat(k,i) &
26628                - dPOLdR2 * erhead_tail(k,2)
26629       gradpepcat(k,j) = gradpepcat(k,j) &
26630                + dPOLdR2 * erhead_tail(k,2)
26631
26632        END DO
26633       RETURN
26634       END SUBROUTINE enq_cat
26635
26636       SUBROUTINE eqd(Ecl,Elj,Epol)
26637       use calc_data
26638       use comm_momo
26639        double precision  facd4, federmaus,ecl,elj,epol
26640        alphapol1 = alphapol(itypi,itypj)
26641        w1        = wqdip(1,itypi,itypj)
26642        w2        = wqdip(2,itypi,itypj)
26643        pis       = sig0head(itypi,itypj)
26644        eps_head   = epshead(itypi,itypj)
26645 !c!-------------------------------------------------------------------
26646 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26647        R1 = 0.0d0
26648        DO k = 1, 3
26649 !c! Calculate head-to-tail distances
26650       R1=R1+(ctail(k,2)-chead(k,1))**2
26651        END DO
26652 !c! Pitagoras
26653        R1 = dsqrt(R1)
26654
26655 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26656 !c!     &        +dhead(1,1,itypi,itypj))**2))
26657 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26658 !c!     &        +dhead(2,1,itypi,itypj))**2))
26659
26660 !c!-------------------------------------------------------------------
26661 !c! ecl
26662        sparrow  = w1 * Qi * om1
26663        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
26664        Ecl = sparrow / Rhead**2.0d0 &
26665          - hawk    / Rhead**4.0d0
26666        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26667              + 4.0d0 * hawk    / Rhead**5.0d0
26668 !c! dF/dom1
26669        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
26670 !c! dF/dom2
26671        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
26672 !c--------------------------------------------------------------------
26673 !c Polarization energy
26674 !c Epol
26675        MomoFac1 = (1.0d0 - chi1 * sqom2)
26676        RR1  = R1 * R1 / MomoFac1
26677        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26678        fgb1 = sqrt( RR1 + a12sq * ee1)
26679        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
26680 !c!       epol = 0.0d0
26681 !c!------------------------------------------------------------------
26682 !c! derivative of Epol is Gpol...
26683        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
26684              / (fgb1 ** 5.0d0)
26685        dFGBdR1 = ( (R1 / MomoFac1)  &
26686            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
26687            / ( 2.0d0 * fgb1 )
26688        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
26689              * (2.0d0 - 0.5d0 * ee1) ) &
26690              / (2.0d0 * fgb1)
26691        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26692 !c!       dPOLdR1 = 0.0d0
26693        dPOLdOM1 = 0.0d0
26694        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26695 !c!       dPOLdOM2 = 0.0d0
26696 !c!-------------------------------------------------------------------
26697 !c! Elj
26698        pom = (pis / Rhead)**6.0d0
26699        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26700 !c! derivative of Elj is Glj
26701        dGLJdR = 4.0d0 * eps_head &
26702         * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26703         +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26704        DO k = 1, 3
26705       erhead(k) = Rhead_distance(k)/Rhead
26706       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26707        END DO
26708
26709        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26710        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26711        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26712        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26713        facd1 = d1 * vbld_inv(i+nres)
26714        facd2 = d2 * vbld_inv(j+nres)
26715        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26716
26717        DO k = 1, 3
26718       hawk = (erhead_tail(k,1) +  &
26719       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
26720
26721       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26722       gvdwx(k,i) = gvdwx(k,i)  &
26723                - dGCLdR * pom&
26724                - dPOLdR1 * hawk &
26725                - dGLJdR * pom
26726
26727       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26728       gvdwx(k,j) = gvdwx(k,j)    &
26729                + dGCLdR * pom  &
26730                + dPOLdR1 * (erhead_tail(k,1) &
26731        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
26732                + dGLJdR * pom
26733
26734
26735       gvdwc(k,i) = gvdwc(k,i)          &
26736                - dGCLdR * erhead(k)  &
26737                - dPOLdR1 * erhead_tail(k,1) &
26738                - dGLJdR * erhead(k)
26739
26740       gvdwc(k,j) = gvdwc(k,j)          &
26741                + dGCLdR * erhead(k)  &
26742                + dPOLdR1 * erhead_tail(k,1) &
26743                + dGLJdR * erhead(k)
26744
26745        END DO
26746        RETURN
26747       END SUBROUTINE eqd
26748       SUBROUTINE edq(Ecl,Elj,Epol)
26749 !       IMPLICIT NONE
26750        use comm_momo
26751       use calc_data
26752
26753       double precision  facd3, adler,ecl,elj,epol
26754        alphapol2 = alphapol(itypj,itypi)
26755        w1        = wqdip(1,itypi,itypj)
26756        w2        = wqdip(2,itypi,itypj)
26757        pis       = sig0head(itypi,itypj)
26758        eps_head  = epshead(itypi,itypj)
26759 !c!-------------------------------------------------------------------
26760 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26761        R2 = 0.0d0
26762        DO k = 1, 3
26763 !c! Calculate head-to-tail distances
26764       R2=R2+(chead(k,2)-ctail(k,1))**2
26765        END DO
26766 !c! Pitagoras
26767        R2 = dsqrt(R2)
26768
26769 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26770 !c!     &        +dhead(1,1,itypi,itypj))**2))
26771 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26772 !c!     &        +dhead(2,1,itypi,itypj))**2))
26773
26774
26775 !c!-------------------------------------------------------------------
26776 !c! ecl
26777        sparrow  = w1 * Qj * om1
26778        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
26779        ECL = sparrow / Rhead**2.0d0 &
26780          - hawk    / Rhead**4.0d0
26781 !c!-------------------------------------------------------------------
26782 !c! derivative of ecl is Gcl
26783 !c! dF/dr part
26784        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26785              + 4.0d0 * hawk    / Rhead**5.0d0
26786 !c! dF/dom1
26787        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
26788 !c! dF/dom2
26789        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
26790 !c--------------------------------------------------------------------
26791 !c Polarization energy
26792 !c Epol
26793        MomoFac2 = (1.0d0 - chi2 * sqom1)
26794        RR2  = R2 * R2 / MomoFac2
26795        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26796        fgb2 = sqrt(RR2  + a12sq * ee2)
26797        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26798        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26799              / (fgb2 ** 5.0d0)
26800        dFGBdR2 = ( (R2 / MomoFac2)  &
26801              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26802              / (2.0d0 * fgb2)
26803        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26804             * (2.0d0 - 0.5d0 * ee2) ) &
26805             / (2.0d0 * fgb2)
26806        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26807 !c!       dPOLdR2 = 0.0d0
26808        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26809 !c!       dPOLdOM1 = 0.0d0
26810        dPOLdOM2 = 0.0d0
26811 !c!-------------------------------------------------------------------
26812 !c! Elj
26813        pom = (pis / Rhead)**6.0d0
26814        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26815 !c! derivative of Elj is Glj
26816        dGLJdR = 4.0d0 * eps_head &
26817          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26818          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26819 !c!-------------------------------------------------------------------
26820 !c! Return the results
26821 !c! (see comments in Eqq)
26822        DO k = 1, 3
26823       erhead(k) = Rhead_distance(k)/Rhead
26824       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26825        END DO
26826        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26827        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26828        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26829        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26830        facd1 = d1 * vbld_inv(i+nres)
26831        facd2 = d2 * vbld_inv(j+nres)
26832        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26833        DO k = 1, 3
26834       condor = (erhead_tail(k,2) &
26835        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26836
26837       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26838       gvdwx(k,i) = gvdwx(k,i) &
26839               - dGCLdR * pom &
26840               - dPOLdR2 * (erhead_tail(k,2) &
26841        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
26842               - dGLJdR * pom
26843
26844       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26845       gvdwx(k,j) = gvdwx(k,j) &
26846               + dGCLdR * pom &
26847               + dPOLdR2 * condor &
26848               + dGLJdR * pom
26849
26850
26851       gvdwc(k,i) = gvdwc(k,i) &
26852               - dGCLdR * erhead(k) &
26853               - dPOLdR2 * erhead_tail(k,2) &
26854               - dGLJdR * erhead(k)
26855
26856       gvdwc(k,j) = gvdwc(k,j) &
26857               + dGCLdR * erhead(k) &
26858               + dPOLdR2 * erhead_tail(k,2) &
26859               + dGLJdR * erhead(k)
26860
26861        END DO
26862        RETURN
26863       END SUBROUTINE edq
26864
26865       SUBROUTINE edq_cat(Ecl,Elj,Epol)
26866       use comm_momo
26867       use calc_data
26868
26869       double precision  facd3, adler,ecl,elj,epol
26870        alphapol2 = alphapolcat(itypj,itypi)
26871        w1        = wqdipcat(1,itypi,itypj)
26872        w2        = wqdipcat(2,itypi,itypj)
26873        pis       = sig0headcat(itypi,itypj)
26874        eps_head  = epsheadcat(itypi,itypj)
26875 !c!-------------------------------------------------------------------
26876 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26877        R2 = 0.0d0
26878        DO k = 1, 3
26879 !c! Calculate head-to-tail distances
26880       R2=R2+(chead(k,2)-ctail(k,1))**2
26881        END DO
26882 !c! Pitagoras
26883        R2 = dsqrt(R2)
26884
26885 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26886 !c!     &        +dhead(1,1,itypi,itypj))**2))
26887 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26888 !c!     &        +dhead(2,1,itypi,itypj))**2))
26889
26890
26891 !c!-------------------------------------------------------------------
26892 !c! ecl
26893 !       write(iout,*) "KURWA2",Rhead
26894        sparrow  = w1 * Qj * om1
26895        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
26896        ECL = sparrow / Rhead**2.0d0 &
26897          - hawk    / Rhead**4.0d0
26898 !c!-------------------------------------------------------------------
26899 !c! derivative of ecl is Gcl
26900 !c! dF/dr part
26901        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
26902              + 4.0d0 * hawk    / Rhead**5.0d0
26903 !c! dF/dom1
26904        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
26905 !c! dF/dom2
26906        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
26907 !c--------------------------------------------------------------------
26908 !c--------------------------------------------------------------------
26909 !c Polarization energy
26910 !c Epol
26911        MomoFac2 = (1.0d0 - chi2 * sqom1)
26912        RR2  = R2 * R2 / MomoFac2
26913        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
26914        fgb2 = sqrt(RR2  + a12sq * ee2)
26915        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
26916        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
26917              / (fgb2 ** 5.0d0)
26918        dFGBdR2 = ( (R2 / MomoFac2)  &
26919              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
26920              / (2.0d0 * fgb2)
26921        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
26922             * (2.0d0 - 0.5d0 * ee2) ) &
26923             / (2.0d0 * fgb2)
26924        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26925 !c!       dPOLdR2 = 0.0d0
26926        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26927 !c!       dPOLdOM1 = 0.0d0
26928        dPOLdOM2 = 0.0d0
26929 !c!-------------------------------------------------------------------
26930 !c! Elj
26931        pom = (pis / Rhead)**6.0d0
26932        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26933 !c! derivative of Elj is Glj
26934        dGLJdR = 4.0d0 * eps_head &
26935          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
26936          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26937 !c!-------------------------------------------------------------------
26938
26939 !c! Return the results
26940 !c! (see comments in Eqq)
26941        DO k = 1, 3
26942       erhead(k) = Rhead_distance(k)/Rhead
26943       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26944        END DO
26945        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26946        erdxj = scalar( erhead(1), dC_norm(1,j) )
26947        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
26948        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26949        facd1 = d1 * vbld_inv(i+nres)
26950        facd2 = d2 * vbld_inv(j)
26951        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
26952        DO k = 1, 3
26953       condor = (erhead_tail(k,2) &
26954        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
26955
26956       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26957       gradpepcatx(k,i) = gradpepcatx(k,i) &
26958               - dGCLdR * pom &
26959               - dPOLdR2 * (erhead_tail(k,2) &
26960        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
26961               - dGLJdR * pom
26962
26963       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
26964 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
26965 !                  + dGCLdR * pom &
26966 !                  + dPOLdR2 * condor &
26967 !                  + dGLJdR * pom
26968
26969
26970       gradpepcat(k,i) = gradpepcat(k,i) &
26971               - dGCLdR * erhead(k) &
26972               - dPOLdR2 * erhead_tail(k,2) &
26973               - dGLJdR * erhead(k)
26974
26975       gradpepcat(k,j) = gradpepcat(k,j) &
26976               + dGCLdR * erhead(k) &
26977               + dPOLdR2 * erhead_tail(k,2) &
26978               + dGLJdR * erhead(k)
26979
26980        END DO
26981        RETURN
26982       END SUBROUTINE edq_cat
26983
26984       SUBROUTINE edq_cat_pep(Ecl,Elj,Epol)
26985       use comm_momo
26986       use calc_data
26987
26988       double precision  facd3, adler,ecl,elj,epol
26989        alphapol2 = alphapolcat(itypj,itypi)
26990        w1        = wqdipcat(1,itypi,itypj)
26991        w2        = wqdipcat(2,itypi,itypj)
26992        pis       = sig0headcat(itypi,itypj)
26993        eps_head  = epsheadcat(itypi,itypj)
26994 !c!-------------------------------------------------------------------
26995 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26996        R2 = 0.0d0
26997        DO k = 1, 3
26998 !c! Calculate head-to-tail distances
26999       R2=R2+(chead(k,2)-ctail(k,1))**2
27000        END DO
27001 !c! Pitagoras
27002        R2 = dsqrt(R2)
27003
27004 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27005 !c!     &        +dhead(1,1,itypi,itypj))**2))
27006 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27007 !c!     &        +dhead(2,1,itypi,itypj))**2))
27008
27009
27010 !c!-------------------------------------------------------------------
27011 !c! ecl
27012        sparrow  = w1 * Qj * om1
27013        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
27014 !       print *,"CO2", itypi,itypj
27015 !       print *,"CO?!.", w1,w2,Qj,om1
27016        ECL = sparrow / Rhead**2.0d0 &
27017          - hawk    / Rhead**4.0d0
27018 !c!-------------------------------------------------------------------
27019 !c! derivative of ecl is Gcl
27020 !c! dF/dr part
27021        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27022              + 4.0d0 * hawk    / Rhead**5.0d0
27023 !c! dF/dom1
27024        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
27025 !c! dF/dom2
27026        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
27027 !c--------------------------------------------------------------------
27028 !c--------------------------------------------------------------------
27029 !c Polarization energy
27030 !c Epol
27031        MomoFac2 = (1.0d0 - chi2 * sqom1)
27032        RR2  = R2 * R2 / MomoFac2
27033        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27034        fgb2 = sqrt(RR2  + a12sq * ee2)
27035        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27036        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27037              / (fgb2 ** 5.0d0)
27038        dFGBdR2 = ( (R2 / MomoFac2)  &
27039              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27040              / (2.0d0 * fgb2)
27041        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27042             * (2.0d0 - 0.5d0 * ee2) ) &
27043             / (2.0d0 * fgb2)
27044        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27045 !c!       dPOLdR2 = 0.0d0
27046        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27047 !c!       dPOLdOM1 = 0.0d0
27048        dPOLdOM2 = 0.0d0
27049 !c!-------------------------------------------------------------------
27050 !c! Elj
27051        pom = (pis / Rhead)**6.0d0
27052        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27053 !c! derivative of Elj is Glj
27054        dGLJdR = 4.0d0 * eps_head &
27055          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27056          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27057 !c!-------------------------------------------------------------------
27058
27059 !c! Return the results
27060 !c! (see comments in Eqq)
27061        DO k = 1, 3
27062       erhead(k) = Rhead_distance(k)/Rhead
27063       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27064        END DO
27065        erdxi = scalar( erhead(1), dC_norm(1,i) )
27066        erdxj = scalar( erhead(1), dC_norm(1,j) )
27067        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27068        adler = scalar( erhead_tail(1,2), dC_norm(1,i) )
27069        facd1 = d1 * vbld_inv(i+1)/2.0
27070        facd2 = d2 * vbld_inv(j)
27071        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+1)/2.0
27072        DO k = 1, 3
27073       condor = (erhead_tail(k,2) &
27074        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27075
27076       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i))
27077 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
27078 !                  - dGCLdR * pom &
27079 !                  - dPOLdR2 * (erhead_tail(k,2) &
27080 !       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27081 !                  - dGLJdR * pom
27082
27083       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
27084 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
27085 !                  + dGCLdR * pom &
27086 !                  + dPOLdR2 * condor &
27087 !                  + dGLJdR * pom
27088
27089
27090       gradpepcat(k,i) = gradpepcat(k,i) +0.5d0*( &
27091               - dGCLdR * erhead(k) &
27092               - dPOLdR2 * erhead_tail(k,2) &
27093               - dGLJdR * erhead(k))
27094       gradpepcat(k,i+1) = gradpepcat(k,i+1) +0.5d0*( &
27095               - dGCLdR * erhead(k) &
27096               - dPOLdR2 * erhead_tail(k,2) &
27097               - dGLJdR * erhead(k))
27098
27099
27100       gradpepcat(k,j) = gradpepcat(k,j) &
27101               + dGCLdR * erhead(k) &
27102               + dPOLdR2 * erhead_tail(k,2) &
27103               + dGLJdR * erhead(k)
27104
27105        END DO
27106        RETURN
27107       END SUBROUTINE edq_cat_pep
27108
27109       SUBROUTINE edd(ECL)
27110 !       IMPLICIT NONE
27111        use comm_momo
27112       use calc_data
27113
27114        double precision ecl
27115 !c!       csig = sigiso(itypi,itypj)
27116        w1 = wqdip(1,itypi,itypj)
27117        w2 = wqdip(2,itypi,itypj)
27118 !c!-------------------------------------------------------------------
27119 !c! ECL
27120        fac = (om12 - 3.0d0 * om1 * om2)
27121        c1 = (w1 / (Rhead**3.0d0)) * fac
27122        c2 = (w2 / Rhead ** 6.0d0) &
27123         * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
27124        ECL = c1 - c2
27125 !c!       write (*,*) "w1 = ", w1
27126 !c!       write (*,*) "w2 = ", w2
27127 !c!       write (*,*) "om1 = ", om1
27128 !c!       write (*,*) "om2 = ", om2
27129 !c!       write (*,*) "om12 = ", om12
27130 !c!       write (*,*) "fac = ", fac
27131 !c!       write (*,*) "c1 = ", c1
27132 !c!       write (*,*) "c2 = ", c2
27133 !c!       write (*,*) "Ecl = ", Ecl
27134 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
27135 !c!       write (*,*) "c2_2 = ",
27136 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
27137 !c!-------------------------------------------------------------------
27138 !c! dervative of ECL is GCL...
27139 !c! dECL/dr
27140        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
27141        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
27142         * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
27143        dGCLdR = c1 - c2
27144 !c! dECL/dom1
27145        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
27146        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
27147         * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
27148        dGCLdOM1 = c1 - c2
27149 !c! dECL/dom2
27150        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
27151        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
27152         * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
27153        dGCLdOM2 = c1 - c2
27154 !c! dECL/dom12
27155        c1 = w1 / (Rhead ** 3.0d0)
27156        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
27157        dGCLdOM12 = c1 - c2
27158 !c!-------------------------------------------------------------------
27159 !c! Return the results
27160 !c! (see comments in Eqq)
27161        DO k= 1, 3
27162       erhead(k) = Rhead_distance(k)/Rhead
27163        END DO
27164        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27165        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27166        facd1 = d1 * vbld_inv(i+nres)
27167        facd2 = d2 * vbld_inv(j+nres)
27168        DO k = 1, 3
27169
27170       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27171       gvdwx(k,i) = gvdwx(k,i)    - dGCLdR * pom
27172       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27173       gvdwx(k,j) = gvdwx(k,j)    + dGCLdR * pom
27174
27175       gvdwc(k,i) = gvdwc(k,i)    - dGCLdR * erhead(k)
27176       gvdwc(k,j) = gvdwc(k,j)    + dGCLdR * erhead(k)
27177        END DO
27178        RETURN
27179       END SUBROUTINE edd
27180       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27181 !       IMPLICIT NONE
27182        use comm_momo
27183       use calc_data
27184
27185        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
27186        eps_out=80.0d0
27187        itypi = itype(i,1)
27188        itypj = itype(j,1)
27189 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
27190 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
27191 !c!       t_bath = 300
27192 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
27193        Rb=0.001986d0
27194        BetaT = 1.0d0 / (298.0d0 * Rb)
27195 !c! Gay-berne var's
27196        sig0ij = sigma( itypi,itypj )
27197        chi1   = chi( itypi, itypj )
27198        chi2   = chi( itypj, itypi )
27199        chi12  = chi1 * chi2
27200        chip1  = chipp( itypi, itypj )
27201        chip2  = chipp( itypj, itypi )
27202        chip12 = chip1 * chip2
27203 !       chi1=0.0
27204 !       chi2=0.0
27205 !       chi12=0.0
27206 !       chip1=0.0
27207 !       chip2=0.0
27208 !       chip12=0.0
27209 !c! not used by momo potential, but needed by sc_angular which is shared
27210 !c! by all energy_potential subroutines
27211        alf1   = 0.0d0
27212        alf2   = 0.0d0
27213        alf12  = 0.0d0
27214 !c! location, location, location
27215 !       xj  = c( 1, nres+j ) - xi
27216 !       yj  = c( 2, nres+j ) - yi
27217 !       zj  = c( 3, nres+j ) - zi
27218        dxj = dc_norm( 1, nres+j )
27219        dyj = dc_norm( 2, nres+j )
27220        dzj = dc_norm( 3, nres+j )
27221 !c! distance from center of chain(?) to polar/charged head
27222 !c!       write (*,*) "istate = ", 1
27223 !c!       write (*,*) "ii = ", 1
27224 !c!       write (*,*) "jj = ", 1
27225        d1 = dhead(1, 1, itypi, itypj)
27226        d2 = dhead(2, 1, itypi, itypj)
27227 !c! ai*aj from Fgb
27228        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
27229 !c!       a12sq = a12sq * a12sq
27230 !c! charge of amino acid itypi is...
27231        Qi  = icharge(itypi)
27232        Qj  = icharge(itypj)
27233        Qij = Qi * Qj
27234 !c! chis1,2,12
27235        chis1 = chis(itypi,itypj)
27236        chis2 = chis(itypj,itypi)
27237        chis12 = chis1 * chis2
27238        sig1 = sigmap1(itypi,itypj)
27239        sig2 = sigmap2(itypi,itypj)
27240 !c!       write (*,*) "sig1 = ", sig1
27241 !c!       write (*,*) "sig2 = ", sig2
27242 !c! alpha factors from Fcav/Gcav
27243        b1cav = alphasur(1,itypi,itypj)
27244 !       b1cav=0.0
27245        b2cav = alphasur(2,itypi,itypj)
27246        b3cav = alphasur(3,itypi,itypj)
27247        b4cav = alphasur(4,itypi,itypj)
27248        wqd = wquad(itypi, itypj)
27249 !c! used by Fgb
27250        eps_in = epsintab(itypi,itypj)
27251        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
27252 !c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
27253 !c!-------------------------------------------------------------------
27254 !c! tail location and distance calculations
27255        Rtail = 0.0d0
27256        DO k = 1, 3
27257       ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
27258       ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
27259        END DO
27260 !c! tail distances will be themselves usefull elswhere
27261 !c1 (in Gcav, for example)
27262        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
27263        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
27264        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
27265        Rtail = dsqrt(  &
27266         (Rtail_distance(1)*Rtail_distance(1))  &
27267       + (Rtail_distance(2)*Rtail_distance(2))  &
27268       + (Rtail_distance(3)*Rtail_distance(3)))
27269 !c!-------------------------------------------------------------------
27270 !c! Calculate location and distance between polar heads
27271 !c! distance between heads
27272 !c! for each one of our three dimensional space...
27273        d1 = dhead(1, 1, itypi, itypj)
27274        d2 = dhead(2, 1, itypi, itypj)
27275
27276        DO k = 1,3
27277 !c! location of polar head is computed by taking hydrophobic centre
27278 !c! and moving by a d1 * dc_norm vector
27279 !c! see unres publications for very informative images
27280       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27281       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
27282 !c! distance
27283 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27284 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27285       Rhead_distance(k) = chead(k,2) - chead(k,1)
27286        END DO
27287 !c! pitagoras (root of sum of squares)
27288        Rhead = dsqrt(   &
27289         (Rhead_distance(1)*Rhead_distance(1)) &
27290       + (Rhead_distance(2)*Rhead_distance(2)) &
27291       + (Rhead_distance(3)*Rhead_distance(3)))
27292 !c!-------------------------------------------------------------------
27293 !c! zero everything that should be zero'ed
27294        Egb = 0.0d0
27295        ECL = 0.0d0
27296        Elj = 0.0d0
27297        Equad = 0.0d0
27298        Epol = 0.0d0
27299        eheadtail = 0.0d0
27300        dGCLdOM1 = 0.0d0
27301        dGCLdOM2 = 0.0d0
27302        dGCLdOM12 = 0.0d0
27303        dPOLdOM1 = 0.0d0
27304        dPOLdOM2 = 0.0d0
27305        RETURN
27306       END SUBROUTINE elgrad_init
27307
27308
27309       SUBROUTINE elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27310       use comm_momo
27311       use calc_data
27312        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
27313        eps_out=80.0d0
27314        itypi = itype(i,1)
27315        itypj = itype(j,5)
27316 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
27317 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
27318 !c!       t_bath = 300
27319 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
27320        Rb=0.001986d0
27321        BetaT = 1.0d0 / (298.0d0 * Rb)
27322 !c! Gay-berne var's
27323        sig0ij = sigmacat( itypi,itypj )
27324        chi1   = chi1cat( itypi, itypj )
27325        chi2   = 0.0d0
27326        chi12  = 0.0d0
27327        chip1  = chipp1cat( itypi, itypj )
27328        chip2  = 0.0d0
27329        chip12 = 0.0d0
27330 !c! not used by momo potential, but needed by sc_angular which is shared
27331 !c! by all energy_potential subroutines
27332        alf1   = 0.0d0
27333        alf2   = 0.0d0
27334        alf12  = 0.0d0
27335        dxj = dc_norm( 1, nres+j )
27336        dyj = dc_norm( 2, nres+j )
27337        dzj = dc_norm( 3, nres+j )
27338 !c! distance from center of chain(?) to polar/charged head
27339        d1 = dheadcat(1, 1, itypi, itypj)
27340        d2 = dheadcat(2, 1, itypi, itypj)
27341 !c! ai*aj from Fgb
27342        a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj)
27343 !c!       a12sq = a12sq * a12sq
27344 !c! charge of amino acid itypi is...
27345        Qi  = icharge(itypi)
27346        Qj  = ichargecat(itypj)
27347        Qij = Qi * Qj
27348 !c! chis1,2,12
27349        chis1 = chis1cat(itypi,itypj)
27350        chis2 = 0.0d0
27351        chis12 = 0.0d0
27352        sig1 = sigmap1cat(itypi,itypj)
27353        sig2 = sigmap2cat(itypi,itypj)
27354 !c! alpha factors from Fcav/Gcav
27355        b1cav = alphasurcat(1,itypi,itypj)
27356        b2cav = alphasurcat(2,itypi,itypj)
27357        b3cav = alphasurcat(3,itypi,itypj)
27358        b4cav = alphasurcat(4,itypi,itypj)
27359        wqd = wquadcat(itypi, itypj)
27360 !c! used by Fgb
27361        eps_in = epsintabcat(itypi,itypj)
27362        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
27363 !c!-------------------------------------------------------------------
27364 !c! tail location and distance calculations
27365        Rtail = 0.0d0
27366        DO k = 1, 3
27367       ctail(k,1)=c(k,i+nres)-dtailcat(1,itypi,itypj)*dc_norm(k,nres+i)
27368       ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
27369        END DO
27370 !c! tail distances will be themselves usefull elswhere
27371 !c1 (in Gcav, for example)
27372        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
27373        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
27374        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
27375        Rtail = dsqrt(  &
27376         (Rtail_distance(1)*Rtail_distance(1))  &
27377       + (Rtail_distance(2)*Rtail_distance(2))  &
27378       + (Rtail_distance(3)*Rtail_distance(3)))
27379 !c!-------------------------------------------------------------------
27380 !c! Calculate location and distance between polar heads
27381 !c! distance between heads
27382 !c! for each one of our three dimensional space...
27383        d1 = dheadcat(1, 1, itypi, itypj)
27384        d2 = dheadcat(2, 1, itypi, itypj)
27385
27386        DO k = 1,3
27387 !c! location of polar head is computed by taking hydrophobic centre
27388 !c! and moving by a d1 * dc_norm vector
27389 !c! see unres publications for very informative images
27390       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27391       chead(k,2) = c(k, j)
27392 !c! distance
27393 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27394 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27395       Rhead_distance(k) = chead(k,2) - chead(k,1)
27396        END DO
27397 !c! pitagoras (root of sum of squares)
27398        Rhead = dsqrt(   &
27399         (Rhead_distance(1)*Rhead_distance(1)) &
27400       + (Rhead_distance(2)*Rhead_distance(2)) &
27401       + (Rhead_distance(3)*Rhead_distance(3)))
27402 !c!-------------------------------------------------------------------
27403 !c! zero everything that should be zero'ed
27404        Egb = 0.0d0
27405        ECL = 0.0d0
27406        Elj = 0.0d0
27407        Equad = 0.0d0
27408        Epol = 0.0d0
27409        eheadtail = 0.0d0
27410        dGCLdOM1 = 0.0d0
27411        dGCLdOM2 = 0.0d0
27412        dGCLdOM12 = 0.0d0
27413        dPOLdOM1 = 0.0d0
27414        dPOLdOM2 = 0.0d0
27415        RETURN
27416       END SUBROUTINE elgrad_init_cat
27417
27418       SUBROUTINE elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27419       use comm_momo
27420       use calc_data
27421        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
27422        eps_out=80.0d0
27423        itypi = 10
27424        itypj = itype(j,5)
27425 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
27426 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
27427 !c!       t_bath = 300
27428 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
27429        Rb=0.001986d0
27430        BetaT = 1.0d0 / (298.0d0 * Rb)
27431 !c! Gay-berne var's
27432        sig0ij = sigmacat( itypi,itypj )
27433        chi1   = chi1cat( itypi, itypj )
27434        chi2   = 0.0d0
27435        chi12  = 0.0d0
27436        chip1  = chipp1cat( itypi, itypj )
27437        chip2  = 0.0d0
27438        chip12 = 0.0d0
27439 !c! not used by momo potential, but needed by sc_angular which is shared
27440 !c! by all energy_potential subroutines
27441        alf1   = 0.0d0
27442        alf2   = 0.0d0
27443        alf12  = 0.0d0
27444        dxj = 0.0d0 !dc_norm( 1, nres+j )
27445        dyj = 0.0d0 !dc_norm( 2, nres+j )
27446        dzj = 0.0d0 !dc_norm( 3, nres+j )
27447 !c! distance from center of chain(?) to polar/charged head
27448        d1 = dheadcat(1, 1, itypi, itypj)
27449        d2 = dheadcat(2, 1, itypi, itypj)
27450 !c! ai*aj from Fgb
27451        a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj)
27452 !c!       a12sq = a12sq * a12sq
27453 !c! charge of amino acid itypi is...
27454        Qi  = 0
27455        Qj  = ichargecat(itypj)
27456 !       Qij = Qi * Qj
27457 !c! chis1,2,12
27458        chis1 = chis1cat(itypi,itypj)
27459        chis2 = 0.0d0
27460        chis12 = 0.0d0
27461        sig1 = sigmap1cat(itypi,itypj)
27462        sig2 = sigmap2cat(itypi,itypj)
27463 !c! alpha factors from Fcav/Gcav
27464        b1cav = alphasurcat(1,itypi,itypj)
27465        b2cav = alphasurcat(2,itypi,itypj)
27466        b3cav = alphasurcat(3,itypi,itypj)
27467        b4cav = alphasurcat(4,itypi,itypj)
27468        wqd = wquadcat(itypi, itypj)
27469 !c! used by Fgb
27470        eps_in = epsintabcat(itypi,itypj)
27471        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
27472 !c!-------------------------------------------------------------------
27473 !c! tail location and distance calculations
27474        Rtail = 0.0d0
27475        DO k = 1, 3
27476       ctail(k,1)=(c(k,i)+c(k,i+1))/2.0-dtailcat(1,itypi,itypj)*dc_norm(k,i)
27477       ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
27478        END DO
27479 !c! tail distances will be themselves usefull elswhere
27480 !c1 (in Gcav, for example)
27481        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
27482        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
27483        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
27484        Rtail = dsqrt(  &
27485         (Rtail_distance(1)*Rtail_distance(1))  &
27486       + (Rtail_distance(2)*Rtail_distance(2))  &
27487       + (Rtail_distance(3)*Rtail_distance(3)))
27488 !c!-------------------------------------------------------------------
27489 !c! Calculate location and distance between polar heads
27490 !c! distance between heads
27491 !c! for each one of our three dimensional space...
27492        d1 = dheadcat(1, 1, itypi, itypj)
27493        d2 = dheadcat(2, 1, itypi, itypj)
27494
27495        DO k = 1,3
27496 !c! location of polar head is computed by taking hydrophobic centre
27497 !c! and moving by a d1 * dc_norm vector
27498 !c! see unres publications for very informative images
27499       chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
27500       chead(k,2) = c(k, j)
27501 !c! distance
27502 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
27503 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
27504       Rhead_distance(k) = chead(k,2) - chead(k,1)
27505        END DO
27506 !c! pitagoras (root of sum of squares)
27507        Rhead = dsqrt(   &
27508         (Rhead_distance(1)*Rhead_distance(1)) &
27509       + (Rhead_distance(2)*Rhead_distance(2)) &
27510       + (Rhead_distance(3)*Rhead_distance(3)))
27511 !c!-------------------------------------------------------------------
27512 !c! zero everything that should be zero'ed
27513        Egb = 0.0d0
27514        ECL = 0.0d0
27515        Elj = 0.0d0
27516        Equad = 0.0d0
27517        Epol = 0.0d0
27518        eheadtail = 0.0d0
27519        dGCLdOM1 = 0.0d0
27520        dGCLdOM2 = 0.0d0
27521        dGCLdOM12 = 0.0d0
27522        dPOLdOM1 = 0.0d0
27523        dPOLdOM2 = 0.0d0
27524        RETURN
27525       END SUBROUTINE elgrad_init_cat_pep
27526
27527       double precision function tschebyshev(m,n,x,y)
27528       implicit none
27529       integer i,m,n
27530       double precision x(n),y,yy(0:maxvar),aux
27531 !c Tschebyshev polynomial. Note that the first term is omitted
27532 !c m=0: the constant term is included
27533 !c m=1: the constant term is not included
27534       yy(0)=1.0d0
27535       yy(1)=y
27536       do i=2,n
27537       yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
27538       enddo
27539       aux=0.0d0
27540       do i=m,n
27541       aux=aux+x(i)*yy(i)
27542       enddo
27543       tschebyshev=aux
27544       return
27545       end function tschebyshev
27546 !C--------------------------------------------------------------------------
27547       double precision function gradtschebyshev(m,n,x,y)
27548       implicit none
27549       integer i,m,n
27550       double precision x(n+1),y,yy(0:maxvar),aux
27551 !c Tschebyshev polynomial. Note that the first term is omitted
27552 !c m=0: the constant term is included
27553 !c m=1: the constant term is not included
27554       yy(0)=1.0d0
27555       yy(1)=2.0d0*y
27556       do i=2,n
27557       yy(i)=2*y*yy(i-1)-yy(i-2)
27558       enddo
27559       aux=0.0d0
27560       do i=m,n
27561       aux=aux+x(i+1)*yy(i)*(i+1)
27562 !C        print *, x(i+1),yy(i),i
27563       enddo
27564       gradtschebyshev=aux
27565       return
27566       end function gradtschebyshev
27567
27568       subroutine make_SCSC_inter_list
27569       include 'mpif.h'
27570       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
27571       real*8 :: dist_init, dist_temp,r_buff_list
27572       integer:: contlisti(250*nres),contlistj(250*nres)
27573 !      integer :: newcontlisti(200*nres),newcontlistj(200*nres)
27574       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_sc,g_ilist_sc
27575       integer displ(0:nprocs),i_ilist_sc(0:nprocs),ierr
27576 !            print *,"START make_SC"
27577         r_buff_list=5.0
27578           ilist_sc=0
27579           do i=iatsc_s,iatsc_e
27580            itypi=iabs(itype(i,1))
27581            if (itypi.eq.ntyp1) cycle
27582            xi=c(1,nres+i)
27583            yi=c(2,nres+i)
27584            zi=c(3,nres+i)
27585           call to_box(xi,yi,zi)
27586            do iint=1,nint_gr(i)
27587             do j=istart(i,iint),iend(i,iint)
27588              itypj=iabs(itype(j,1))
27589              if (itypj.eq.ntyp1) cycle
27590              xj=c(1,nres+j)
27591              yj=c(2,nres+j)
27592              zj=c(3,nres+j)
27593              call to_box(xj,yj,zj)
27594 !          call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
27595 !          faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
27596           xj=boxshift(xj-xi,boxxsize)
27597           yj=boxshift(yj-yi,boxysize)
27598           zj=boxshift(zj-zi,boxzsize)
27599           dist_init=xj**2+yj**2+zj**2
27600 !             dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
27601 ! r_buff_list is a read value for a buffer
27602              if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
27603 ! Here the list is created
27604              ilist_sc=ilist_sc+1
27605 ! this can be substituted by cantor and anti-cantor
27606              contlisti(ilist_sc)=i
27607              contlistj(ilist_sc)=j
27608
27609              endif
27610            enddo
27611            enddo
27612            enddo
27613 !         call MPI_Reduce(ilist_sc,g_ilist_sc,1,&
27614 !          MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
27615 !        call MPI_Gather(newnss,1,MPI_INTEGER,&
27616 !                        i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
27617 #ifdef DEBUG
27618       write (iout,*) "before MPIREDUCE",ilist_sc
27619       do i=1,ilist_sc
27620       write (iout,*) i,contlisti(i),contlistj(i)
27621       enddo
27622 #endif
27623       if (nfgtasks.gt.1)then
27624
27625       call MPI_Reduce(ilist_sc,g_ilist_sc,1,&
27626         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
27627 !        write(iout,*) "before bcast",g_ilist_sc
27628       call MPI_Gather(ilist_sc,1,MPI_INTEGER,&
27629                   i_ilist_sc,1,MPI_INTEGER,king,FG_COMM,IERR)
27630       displ(0)=0
27631       do i=1,nfgtasks-1,1
27632         displ(i)=i_ilist_sc(i-1)+displ(i-1)
27633       enddo
27634 !        write(iout,*) "before gather",displ(0),displ(1)
27635       call MPI_Gatherv(contlisti,ilist_sc,MPI_INTEGER,&
27636                    newcontlisti,i_ilist_sc,displ,MPI_INTEGER,&
27637                    king,FG_COMM,IERR)
27638       call MPI_Gatherv(contlistj,ilist_sc,MPI_INTEGER,&
27639                    newcontlistj,i_ilist_sc,displ,MPI_INTEGER,&
27640                    king,FG_COMM,IERR)
27641       call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM,IERR)
27642 !        write(iout,*) "before bcast",g_ilist_sc
27643 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27644       call MPI_Bcast(newcontlisti,g_ilist_sc,MPI_INT,king,FG_COMM,IERR)
27645       call MPI_Bcast(newcontlistj,g_ilist_sc,MPI_INT,king,FG_COMM,IERR)
27646
27647 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27648
27649       else
27650       g_ilist_sc=ilist_sc
27651
27652       do i=1,ilist_sc
27653       newcontlisti(i)=contlisti(i)
27654       newcontlistj(i)=contlistj(i)
27655       enddo
27656       endif
27657
27658 #ifdef DEBUG
27659       write (iout,*) "after MPIREDUCE",g_ilist_sc
27660       do i=1,g_ilist_sc
27661       write (iout,*) i,newcontlisti(i),newcontlistj(i)
27662       enddo
27663 #endif
27664       call int_bounds(g_ilist_sc,g_listscsc_start,g_listscsc_end)
27665       return
27666       end subroutine make_SCSC_inter_list
27667 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
27668
27669       subroutine make_SCp_inter_list
27670       use MD_data,  only: itime_mat
27671
27672       include 'mpif.h'
27673       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
27674       real*8 :: dist_init, dist_temp,r_buff_list
27675       integer:: contlistscpi(250*nres),contlistscpj(250*nres)
27676 !      integer :: newcontlistscpi(200*nres),newcontlistscpj(200*nres)
27677       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_scp,g_ilist_scp
27678       integer displ(0:nprocs),i_ilist_scp(0:nprocs),ierr
27679 !            print *,"START make_SC"
27680       r_buff_list=5.0
27681           ilist_scp=0
27682       do i=iatscp_s,iatscp_e
27683       if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
27684       xi=0.5D0*(c(1,i)+c(1,i+1))
27685       yi=0.5D0*(c(2,i)+c(2,i+1))
27686       zi=0.5D0*(c(3,i)+c(3,i+1))
27687         call to_box(xi,yi,zi)
27688       do iint=1,nscp_gr(i)
27689
27690       do j=iscpstart(i,iint),iscpend(i,iint)
27691         itypj=iabs(itype(j,1))
27692         if (itypj.eq.ntyp1) cycle
27693 ! Uncomment following three lines for SC-p interactions
27694 !         xj=c(1,nres+j)-xi
27695 !         yj=c(2,nres+j)-yi
27696 !         zj=c(3,nres+j)-zi
27697 ! Uncomment following three lines for Ca-p interactions
27698 !          xj=c(1,j)-xi
27699 !          yj=c(2,j)-yi
27700 !          zj=c(3,j)-zi
27701         xj=c(1,j)
27702         yj=c(2,j)
27703         zj=c(3,j)
27704         call to_box(xj,yj,zj)
27705       xj=boxshift(xj-xi,boxxsize)
27706       yj=boxshift(yj-yi,boxysize)
27707       zj=boxshift(zj-zi,boxzsize)
27708       dist_init=xj**2+yj**2+zj**2
27709 #ifdef DEBUG
27710             ! r_buff_list is a read value for a buffer
27711              if ((sqrt(dist_init).le.(r_cut_ele)).and.(ifirstrun.eq.0)) then
27712 ! Here the list is created
27713              ilist_scp_first=ilist_scp_first+1
27714 ! this can be substituted by cantor and anti-cantor
27715              contlistscpi_f(ilist_scp_first)=i
27716              contlistscpj_f(ilist_scp_first)=j
27717             endif
27718 #endif
27719 ! r_buff_list is a read value for a buffer
27720              if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
27721 ! Here the list is created
27722              ilist_scp=ilist_scp+1
27723 ! this can be substituted by cantor and anti-cantor
27724              contlistscpi(ilist_scp)=i
27725              contlistscpj(ilist_scp)=j
27726             endif
27727            enddo
27728            enddo
27729            enddo
27730 #ifdef DEBUG
27731       write (iout,*) "before MPIREDUCE",ilist_scp
27732       do i=1,ilist_scp
27733       write (iout,*) i,contlistscpi(i),contlistscpj(i)
27734       enddo
27735 #endif
27736       if (nfgtasks.gt.1)then
27737
27738       call MPI_Reduce(ilist_scp,g_ilist_scp,1,&
27739         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
27740 !        write(iout,*) "before bcast",g_ilist_sc
27741       call MPI_Gather(ilist_scp,1,MPI_INTEGER,&
27742                   i_ilist_scp,1,MPI_INTEGER,king,FG_COMM,IERR)
27743       displ(0)=0
27744       do i=1,nfgtasks-1,1
27745         displ(i)=i_ilist_scp(i-1)+displ(i-1)
27746       enddo
27747 !        write(iout,*) "before gather",displ(0),displ(1)
27748       call MPI_Gatherv(contlistscpi,ilist_scp,MPI_INTEGER,&
27749                    newcontlistscpi,i_ilist_scp,displ,MPI_INTEGER,&
27750                    king,FG_COMM,IERR)
27751       call MPI_Gatherv(contlistscpj,ilist_scp,MPI_INTEGER,&
27752                    newcontlistscpj,i_ilist_scp,displ,MPI_INTEGER,&
27753                    king,FG_COMM,IERR)
27754       call MPI_Bcast(g_ilist_scp,1,MPI_INT,king,FG_COMM,IERR)
27755 !        write(iout,*) "before bcast",g_ilist_sc
27756 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27757       call MPI_Bcast(newcontlistscpi,g_ilist_scp,MPI_INT,king,FG_COMM,IERR)
27758       call MPI_Bcast(newcontlistscpj,g_ilist_scp,MPI_INT,king,FG_COMM,IERR)
27759
27760 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27761
27762       else
27763       g_ilist_scp=ilist_scp
27764
27765       do i=1,ilist_scp
27766       newcontlistscpi(i)=contlistscpi(i)
27767       newcontlistscpj(i)=contlistscpj(i)
27768       enddo
27769       endif
27770
27771 #ifdef DEBUG
27772       write (iout,*) "after MPIREDUCE",g_ilist_scp
27773       do i=1,g_ilist_scp
27774       write (iout,*) i,newcontlistscpi(i),newcontlistscpj(i)
27775       enddo
27776
27777 !      if (ifirstrun.eq.0) ifirstrun=1
27778 !      do i=1,ilist_scp_first
27779 !       do j=1,g_ilist_scp
27780 !        if ((newcontlistscpi(j).eq.contlistscpi_f(i)).and.&
27781 !         (newcontlistscpj(j).eq.contlistscpj_f(i))) go to 126
27782 !        enddo
27783 !       print *,itime_mat,"ERROR matrix needs updating"
27784 !       print *,contlistscpi_f(i),contlistscpj_f(i)
27785 !  126  continue
27786 !      enddo
27787 #endif
27788       call int_bounds(g_ilist_scp,g_listscp_start,g_listscp_end)
27789
27790       return
27791       end subroutine make_SCp_inter_list
27792
27793 !-----------------------------------------------------------------------------
27794 !-----------------------------------------------------------------------------
27795
27796
27797       subroutine make_pp_inter_list
27798       include 'mpif.h'
27799       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
27800       real*8 :: xmedj,ymedj,zmedj,sslipi,ssgradlipi,faclipij2,sslipj,ssgradlipj
27801       real*8 :: dist_init, dist_temp,r_buff_list,dxi,dyi,dzi,xmedi,ymedi,zmedi
27802       real*8 :: dx_normi,dy_normi,dz_normi,dxj,dyj,dzj,dx_normj,dy_normj,dz_normj
27803       integer:: contlistppi(250*nres),contlistppj(250*nres)
27804 !      integer :: newcontlistppi(200*nres),newcontlistppj(200*nres)
27805       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_pp,g_ilist_pp
27806       integer displ(0:nprocs),i_ilist_pp(0:nprocs),ierr
27807 !            write(iout,*),"START make_pp",iatel_s,iatel_e,r_cut_ele+r_buff_list
27808             ilist_pp=0
27809       r_buff_list=5.0
27810       do i=iatel_s,iatel_e
27811         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
27812         dxi=dc(1,i)
27813         dyi=dc(2,i)
27814         dzi=dc(3,i)
27815         dx_normi=dc_norm(1,i)
27816         dy_normi=dc_norm(2,i)
27817         dz_normi=dc_norm(3,i)
27818         xmedi=c(1,i)+0.5d0*dxi
27819         ymedi=c(2,i)+0.5d0*dyi
27820         zmedi=c(3,i)+0.5d0*dzi
27821
27822         call to_box(xmedi,ymedi,zmedi)
27823         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
27824 !          write (iout,*) i,j,itype(i,1),itype(j,1)
27825 !          if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
27826
27827 ! 1,j)
27828              do j=ielstart(i),ielend(i)
27829 !          write (iout,*) i,j,itype(i,1),itype(j,1)
27830           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
27831           dxj=dc(1,j)
27832           dyj=dc(2,j)
27833           dzj=dc(3,j)
27834           dx_normj=dc_norm(1,j)
27835           dy_normj=dc_norm(2,j)
27836           dz_normj=dc_norm(3,j)
27837 !          xj=c(1,j)+0.5D0*dxj-xmedi
27838 !          yj=c(2,j)+0.5D0*dyj-ymedi
27839 !          zj=c(3,j)+0.5D0*dzj-zmedi
27840           xj=c(1,j)+0.5D0*dxj
27841           yj=c(2,j)+0.5D0*dyj
27842           zj=c(3,j)+0.5D0*dzj
27843           call to_box(xj,yj,zj)
27844 !          call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
27845 !          faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
27846           xj=boxshift(xj-xmedi,boxxsize)
27847           yj=boxshift(yj-ymedi,boxysize)
27848           zj=boxshift(zj-zmedi,boxzsize)
27849           dist_init=xj**2+yj**2+zj**2
27850       if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
27851 ! Here the list is created
27852                  ilist_pp=ilist_pp+1
27853 ! this can be substituted by cantor and anti-cantor
27854                  contlistppi(ilist_pp)=i
27855                  contlistppj(ilist_pp)=j
27856               endif
27857 !             enddo
27858              enddo
27859              enddo
27860 #ifdef DEBUG
27861       write (iout,*) "before MPIREDUCE",ilist_pp
27862       do i=1,ilist_pp
27863       write (iout,*) i,contlistppi(i),contlistppj(i)
27864       enddo
27865 #endif
27866       if (nfgtasks.gt.1)then
27867
27868         call MPI_Reduce(ilist_pp,g_ilist_pp,1,&
27869           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
27870 !        write(iout,*) "before bcast",g_ilist_sc
27871         call MPI_Gather(ilist_pp,1,MPI_INTEGER,&
27872                         i_ilist_pp,1,MPI_INTEGER,king,FG_COMM,IERR)
27873         displ(0)=0
27874         do i=1,nfgtasks-1,1
27875           displ(i)=i_ilist_pp(i-1)+displ(i-1)
27876         enddo
27877 !        write(iout,*) "before gather",displ(0),displ(1)
27878         call MPI_Gatherv(contlistppi,ilist_pp,MPI_INTEGER,&
27879                          newcontlistppi,i_ilist_pp,displ,MPI_INTEGER,&
27880                          king,FG_COMM,IERR)
27881         call MPI_Gatherv(contlistppj,ilist_pp,MPI_INTEGER,&
27882                          newcontlistppj,i_ilist_pp,displ,MPI_INTEGER,&
27883                          king,FG_COMM,IERR)
27884         call MPI_Bcast(g_ilist_pp,1,MPI_INT,king,FG_COMM,IERR)
27885 !        write(iout,*) "before bcast",g_ilist_sc
27886 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27887         call MPI_Bcast(newcontlistppi,g_ilist_pp,MPI_INT,king,FG_COMM,IERR)
27888         call MPI_Bcast(newcontlistppj,g_ilist_pp,MPI_INT,king,FG_COMM,IERR)
27889
27890 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
27891
27892         else
27893         g_ilist_pp=ilist_pp
27894
27895         do i=1,ilist_pp
27896         newcontlistppi(i)=contlistppi(i)
27897         newcontlistppj(i)=contlistppj(i)
27898         enddo
27899         endif
27900         call int_bounds(g_ilist_pp,g_listpp_start,g_listpp_end)
27901 #ifdef DEBUG
27902       write (iout,*) "after MPIREDUCE",g_ilist_pp
27903       do i=1,g_ilist_pp
27904       write (iout,*) i,newcontlistppi(i),newcontlistppj(i)
27905       enddo
27906 #endif
27907       return
27908       end subroutine make_pp_inter_list
27909
27910 !-----------------------------------------------------------------------------
27911       double precision function boxshift(x,boxsize)
27912       implicit none
27913       double precision x,boxsize
27914       double precision xtemp
27915       xtemp=dmod(x,boxsize)
27916       if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
27917         boxshift=xtemp-boxsize
27918       else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
27919         boxshift=xtemp+boxsize
27920       else
27921         boxshift=xtemp
27922       endif
27923       return
27924       end function boxshift
27925 !-----------------------------------------------------------------------------
27926       subroutine to_box(xi,yi,zi)
27927       implicit none
27928 !      include 'DIMENSIONS'
27929 !      include 'COMMON.CHAIN'
27930       double precision xi,yi,zi
27931       xi=dmod(xi,boxxsize)
27932       if (xi.lt.0.0d0) xi=xi+boxxsize
27933       yi=dmod(yi,boxysize)
27934       if (yi.lt.0.0d0) yi=yi+boxysize
27935       zi=dmod(zi,boxzsize)
27936       if (zi.lt.0.0d0) zi=zi+boxzsize
27937       return
27938       end subroutine to_box
27939 !--------------------------------------------------------------------------
27940       subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
27941       implicit none
27942 !      include 'DIMENSIONS'
27943 !      include 'COMMON.IOUNITS'
27944 !      include 'COMMON.CHAIN'
27945       double precision xi,yi,zi,sslipi,ssgradlipi
27946       double precision fracinbuf
27947 !      double precision sscalelip,sscagradlip
27948 #ifdef DEBUG
27949       write (iout,*) "bordlipbot",bordlipbot," bordliptop",bordliptop
27950       write (iout,*) "buflipbot",buflipbot," lipbufthick",lipbufthick
27951       write (iout,*) "xi yi zi",xi,yi,zi
27952 #endif
27953       if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
27954 ! the energy transfer exist
27955         if (zi.lt.buflipbot) then
27956 ! what fraction I am in
27957           fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
27958 ! lipbufthick is thickenes of lipid buffore
27959           sslipi=sscalelip(fracinbuf)
27960           ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
27961         elseif (zi.gt.bufliptop) then
27962           fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
27963           sslipi=sscalelip(fracinbuf)
27964           ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
27965         else
27966           sslipi=1.0d0
27967           ssgradlipi=0.0
27968         endif
27969       else
27970         sslipi=0.0d0
27971         ssgradlipi=0.0
27972       endif
27973 #ifdef DEBUG
27974       write (iout,*) "sslipi",sslipi," ssgradlipi",ssgradlipi
27975 #endif
27976       return
27977       end subroutine lipid_layer
27978
27979 !--------------------------------------------------------------------------
27980 !--------------------------------------------------------------------------
27981       end module energy